Squares

General FreeBASIC programming questions.
bfuller
Posts: 339
Joined: Jun 02, 2007 12:35
Location: Sydney, Australia

Re: Squares

Postby bfuller » Jan 08, 2020 0:32

dodicat wrote:Lucky you can do that beer thing Albert.
I live in a village which now has no shop, no pub, no post office, no village hall, and the only telephone box was removed three weeks ago.

WHAT !!!!!
There are five bottle shops within a few minutes of each other where I live. And we need a drink to wash the bushfire smoke taste from our throats too.
You should emigrate----but might be a bit hot for you---it was 46.3 C (Celsius) on my back doorstep, on the shady side of the house a couple days ago.
Last edited by bfuller on Jan 08, 2020 1:04, edited 2 times in total.
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jan 08, 2020 0:44

Here in Santa Barbara , California U.S.A

It's 70 degrees today.. In January 7th...
My birthday is Thursday Jan 9th , I'll be 54..
Every second Thursday of the month , we have a pizza party at the apartment complex where i live..
We get the pizzas from Costco , they charge $10 for a pizza , any kind you like , their all the same price.. $6 for a half and $10 for a whole.
I get a whole Supreme with no meat, just veggies. The pizzas are like 18 to 20 inches across..


Some winters it does get cold..
Back in Feb 2009 it snowed , but it melted as soon as it hit the ground..
Back in 2007 it got real cold , and froze all the orange crops , cost the state like 2 billion in lost orange crops..

But mostly it's mild in the winter , upper 50's and lower to mid 60's
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jan 08, 2020 1:14

I'll be 54 Thursday , how time flies.

It seems , that just yesterday. I dropped out of 11th grade and joined the U.S. Army.. and that was back in 1983
They kicked me out , after 13 months , said i wasn't Army material..

But the memories of boot-camp are still fresh in my mind..
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jan 08, 2020 1:21

@badidea

badidea wrote:Won't work, not even the gods can solve that.
0011 000 = 001 1000
0011 001 = 001 1001



Thanks for the code...

I'll play around with it... To see if i can cancel the problems.. I think I've used all 16 values.. I'll see..

Once you get above 10,000 bytes in , every combination is utilized..so it would be a problem...
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Time-Rhyme

Postby albert » Jan 08, 2020 2:44

I've come up with all the sayings for my "Time-Rhyme" program..

oh = so , yo , go , know , no

clock = coc# , knock , dock

1 = fun , gun , bun , done
2 = blue , blew , knew , new , too , do , chew , jew , screw
3 = she , free , key , bee , sea
4 = who#e , sore , score , more , door
5 = wive , live , drive , hive
6 = chicks , licks , fix , dic#s
7 = seven , leaven , heaven
8 = ate , mate , date , gate
9 = fine , tine , dine , nine

11 = she-heaven , see-heaven , be-heaven , she-leaven
12 = helve , delve
13 = flirting , squirting
14 = who#e teen
15 = shifting , lifting
16 = sixteen , dic#s teen
17 = heaven teen
18 = mating , waiting
19 = fine teen

10 = hen , den
20 = funny , bunny , honey , plunny ( plenty )
30 = squirty , purty , dirty
40 = shorty , sporty , courty , w#orey
50 = shifty , lifty , nifty

The teens are hard to make good rhymes out of... But the British number system lends itself well to "Time-Rhymes"

So you can use all the values to make rhymes..
like:
1:00 "bun go dock"
1:51 "fun shifty bun"
11:39 "she-leaven dirty tine" etc...
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jan 08, 2020 23:56

Thanks you guys for all the help...
dodicat
Posts: 6728
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Postby dodicat » Jan 09, 2020 13:16

Richard wrote:The old Circles topic evolved for people who go round in circles, the Squares topic was created for square people, not for experts in the calculus of geometry. Squares is somewhere the bonds of reality can be shed, along with the bounds of mathematics.

Albert needs a challenge that he believes is possible. FB can be a medium, like oil paint. You can dab it onto a page with your fingers or a brush, then step back to appreciate the result. Everyone learns at different rates and we all reach different points of suspended development in our many different dimensions of expression.

@angros47
I hope you can understand that it is better to support those in squares than to attack or abandon them. They should not be condemned to wander like the “Flying Dutchman”, scattering random posts throughout the forum forever.
https://en.wikipedia.org/wiki/Flying_Dutchman
https://en.wikipedia.org/wiki/Dunning%E ... ger_effect


Squares and circles, the forum's best threads by far.
Pretend
I saw the Flying dutchman in 1972, I took a picture and got it enlarged and put it up in the mess room.
I haven't seen that ship since.

Code: Select all

 Dim As String zz = _
"S2C0BM50,108M+4,42M+7,7M+1,15M+-6,2M+1,6"_
&"M+38,-1M+-1,-7M+-32,0"_
&"BM+14,4P4294932224,0"_
&"BM+-2,4M+6,7"_
&"M+-2,10M+2,5M+2,17M+2,20M+-1,2M+260,0"_
&"M+16,-10M+9,-13M+5,-16M+5,-11M+14,-7M+14,-6"_
&"M+10,-8M+-55,8M+-13,-6M+-52,3M+-41,3M+-42,1"_
&"M+-22,-2M+-45,-3M+-26,-5M+0,0M+-24,-5M+0,0"_
&"M+-31,-7M+-2,14M+30,1M+1,8M+2,0"_
&"M+0,0M+0,0M+-20,2"_
&"BM+154,32P4288822016,0"_
&"BM+-165,-29M+1,26"_
&"M+-3,18M+0,12M+0,0M+16,-1M+0,-16M+-1,-18"_
&"M+-1,-14M+-2,-6M+-8,-1"_
&"B"_
&"BM+2,-1M+-4,1"_
&""_
&"BM+7,28P4285822068,0"_
&"BM+5,-95M+22,9M+15,9M+4,1M+0,10"_
&"M+16,5M+24,3M+25,4M+8,14M+2,4"_
&"B"_
&"BM+-143,-70M+3,2M+25,7M+3,3M+0,-1"_
&"BM+-28,14M+9,0M+12,5M+9,0M+14,5M+18,7"_
&"M+5,0"_
&"BM+-51,-30M+0,14M+-4,-16M+-1,16M+1,8"_
&"M+-3,10M+8,-10M+-2,14M+8,1M+1,-12"_
&"BM+30,11"_
&"P4285412870,0"_
&"BM+-31,-30P4283708934,0"_
&"BM+195,48M+5,-7M+0,-4M+66,-3M+7,12"_
&""_
&"B"_
&"BM+-80,2M+2,4M+0,-2"_
&"BM+21,-6P4283708934,0"_
&"BM+59,2M+135,-83"_
&"M+-127,87"_
&"BM+6,-7"_
&"B"_
&"BM+-2,5M+1,5"_
&"B"_
&"BM+-6,-13M+-13,6"_
&"BM+16,-1P4279308561,0"_
&"BM+1,-2P4281940281,0"_
&"BM+-39,-10"_
&"BM+6,1M+-8,0"_
&"M+9,-99M+6,1M+-6,98M+-2,0"_
&"BM+0,-23P4281940281,0"_
&"B"_
&"BM+2,-76M+-11,-12M+2,-6M+1,1"_
&"M+25,0M+-3,13M+-8,4M+-2,-1"_
&"B"_
&"BM+-1,-12"_
&"P4294912000,0"_
&"BM+-3,-8M+0,3M+7,-103"_
&"BM+1,1M+3,-1"_
&"M+-2,102M+0,2"_
&"BM+-3,-10"_
&"P4283848278,0"_
&"BM+6,-96M+1,-22"_
&"BM+-136,265M+1,-126M+5,0M+4,125"_
&"BM+-4,-29"_
&"P4283848278,0"_
&"BM+1,-96M+8,-6M+0,-10M+-26,1M+0,8"_
&"M+4,6M+9,2"_
&"BM+-1,-9P4294919424,0"_
&"BM+-1,-8M+4,-123M+4,-1"_
&"M+1,124"_
&"BM+-5,-15P4283256141,0"_
&"BM+-107,106M+9,3M+0,-68M+-6,1"_
&"M+-1,64"_
&"BM+2,-13P4283256141,0"_
&"BM+4,-54M+8,-1M+-1,-8M+-19,0"_
&"M+-1,10M+10,3"_
&"M+11,-5"_
&"BM+-18,-3P4294919424,0"_
&"BM+3,-7M+0,1M+-1,-99M+6,1M+3,98"_
&"BP4283256141,0"_
&"BM+-4,-12"_
&"P4283256141,0"_
&"BM+-1,25M+-15,77M+7,0M+9,-76M+-2,77"_
&"BM+-11,-11"_
&"M+12,-2M+0,-8M+-10,0M+2,-4M+8,0M+0,-5"_
&"M+-10,0M+3,-7M+7,3M+0,-8M+-7,2"_
&"BM+112,-47"_
&"M+-64,136M+9,1M+52,-135M+-44,135M+11,0M+36,-136"_
&"M+-22,136M+6,2M+15,-136M+-58,111M+46,2M+3,-7"_
&"M+-41,-4M+4,-6M+37,1M+1,-8M+-34,-3M+5,-8"_
&"M+27,1M+4,-10M+-28,-2M+4,-8M+22,1M+4,-11"_
&"M+-23,1M+4,-10M+17,0M+3,-9M+-14,-2"_
&"B"_
&"BM+135,-29"_
&"M+-36,114M+8,1M+31,-112M+-25,114M+0,0M+7,-1"_
&"M+0,0M+15,-112M+-5,110M+7,-107M+-6,106M+10,0"_
&"M+-5,-107"_
&"BM+-192,131M+64,3M+0,-4M+-56,-4"_
&"M+-5,5"_
&"BM+24,-2"_
&"BM+0,0P4294955008,0"_
&"BM+0,-58M+-117,-153M+9,2"_
&"M+111,147M+-6,4"_
&"B"_
&"BM+-71,-104P4283848278,0"_
&"BM+71,95P4283848278,0"_
&"BM+-39,54"_
&"M+1,8M+7,0M+-1,-7M+-11,0"_
&""_
&"BM+8,3P4283848278,0"_
&"BM+89,-2M+2,8M+6,0M+1,-8M+-10,0"_
&""_
&"BM+5,5P4283848278,0"_
&"B"_
&"BM+22,-4M+12,-1"_
&"M+0,11M+-13,-1M+1,-9"_
&"BM+3,2P4283848278,0"_
&"BM+27,-4M+14,0"_
&"M+-2,10M+-10,-1M+0,-9"_
&"BM+3,3P4283848278,0"_
&"BM+90,7M+-19,10"_
&"M+-3,-5M+2,-4M+-3,8M+8,6M+0,5M+6,-1"_
&""_
&"B"
Dim As String szz=zz
szz="S1"+Rtrim(zz,"S2")


Dim As String b = _
"C"+Str(Rgb(0,0,0))+"BM0,98M+99,0M+0,-100M+-12,-30M+-16,-15M+-18,-15"_
&"M+2,-24M+-15,1M+4,23M+-21,14M+-15,14M+-5,18"_
&"M+-4,13M+0,101"_
&"B"_
&"BM+49,-51P"+Str(Rgb(255,0,255))+","+Str(Rgb(0,0,0))'4278241280"


Type v2
    As Long x,y
End Type

Type d2
    As Single mx,my
    As Single mw,dy
End Type

#define A_R( c ) ( ( c ) Shr 16 And 255 )
#define A_G( c ) ( ( c ) Shr  8 And 255 )
#define A_B( c ) ( ( c )        And 255 )

Sub rotateimage(Byref dest As Any Ptr=0,im As Any Ptr,angle As Single,shiftx As Long=0,shifty As Long=0,sc As Single=1,miss As Ulong=Rgb(255,0,255),fixedpivot As boolean=false)
    Static As Integer pitch,pitchs,xres,yres,runflag
    Static As Any Ptr row,rows
    Static As Integer ddx,ddy,resultx,resulty
    Imageinfo im,ddx,ddy,,pitch,row
    If dest=0 Then
    Screeninfo xres,yres,,,pitchS
    rowS=Screenptr
    Else
    If sc<>1 Then
        Dim As Integer x,y
        Imageinfo dest,x,y
    Imagedestroy dest:dest=0: dest=Imagecreate(x*sc,y*sc)
    End If
    Imageinfo dest, xres,yres,,pitchS,rows
    End If
    Dim As Long centreX=ddx\2,centreY=ddy\2
    Dim As Single sx=Sin(angle)
    Dim As Single cx=Cos(angle)
    Dim As Long mx=Iif(ddx>=ddy,ddx,ddy),shftx,shfty
    Var fx=sc*.7071067811865476,sc2=1/sc
    If fixedpivot=false Then
     shiftx+=centreX*sc-centrex
     shiftY+=centrey*sc-centrey
     End If
    For y As Long=centrey-fx*mx+1 To centrey+ fx*mx
        Dim As Single sxcy=Sx*(y-centrey),cxcy=Cx*(y-centrey)
        shfty=y+shifty
        For x As Long=centrex-mx*fx To centrex+mx*fx
                 If x+shiftx >=0 Then 'on the screen
                    If x+shiftx <xres Then
                        If shfty >=0 Then
                            If shfty<yres Then
            resultx=sc2*(Cx*(x-centrex)-Sxcy) +centrex:resulty=sc2*(Sx*(x-centrex)+Cxcy) +centrey
                If resultx >=0 Then 'on the image
                    If resultx<ddx Then
                        If resulty>=0 Then
                            If resulty<ddy Then
    Dim As Ulong u=*Cast(Ulong Ptr,row+pitch*((resultY))+((resultX)) Shl 2 ) 'point(image)
   If u<>miss Then *Cast(Ulong Ptr,rowS+pitchS*(y+shifty)+(x+shiftx) Shl 2)= u 'pset (screen)
                End If:End If:End If:End If
                End If:End If:End If:End If
        Next x
    Next y
End Sub

 Sub thickline(x1 As Single,_
            y1 As Single,_
            x2 As Single,_
            y2 As Single,_
            thickness As Single,_
            colour As Ulong, _
            i As Any Ptr=0)
            If thickness<2 Then
                Line i,(x1,y1)-(x2,y2),colour
            Else               
                Var h=Sqr((x2-x1)*(x2-x1)+(y2-y1)*(y2-y1))  'hypotenuse
                Var s=(y1-y2)/h                             'sine
                Var c=(x2-x1)/h                             'cosine
                Dim As Ulong prime=Rgb(253,254,255)
                For n As Integer=1 To 2
                    Line i,(x1+s*thickness/2,y1+c*thickness/2)-(x2+s*thickness/2,y2+c*thickness/2),prime
                    Line i,(x1-s*thickness/2,y1-c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),prime
                    Line i,(x1+s*thickness/2,y1+c*thickness/2)-(x1-s*thickness/2,y1-c*thickness/2),prime
                    Line i,(x2+s*thickness/2,y2+c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),prime
                    Paint i,((x1+x2)/2,(y1+y2)/2),prime,prime
                    prime=colour
                Next n
            End If
        End Sub
       
    Function r2d (pivotx As Single,pivoty As Single,px As Single,py As Single,a As Single,scale As Single=1) As v2
    Return Type(scale*(Cos(a)*(px-pivotx)-Sin(a)*(py-pivoty))+pivotx, _
                scale*(Sin(a)*(px-pivotx)+Cos(a)*(py-pivoty))+pivoty)
    End Function
   
    Function shortline(fp As v2,p As v2,length As Long) As v2
    Dim As Single diffx=p.x-fp.x,diffy=p.y-fp.y
    Dim As Single L=Sqr(diffx*diffx+diffy*diffy)
    Return Type(fp.x+length*diffx/L,fp.y+length*diffy/L)
    End Function
   
    Sub throughview(b As d2,a As Single=2.9)
    Static  As Ulong _colour(81,81),clr
    Static As Long result
    #macro rotate(pivotx,pivoty,px,py,a,scale)
    Var Newx=scale*((px-pivotx))+pivotx
    Var Newy=scale*((py-pivoty))+pivoty
    #endmacro
    #macro incircle(cx,cy,r,mx,my,a)
    If a<=1 Then
        result=a*(cx-mx)*a*(cx-mx) +1*(cy-my)*1*(cy-my)<= r*r*a*a
    Else
        result=a*(cx-mx)*a*(cx-mx) +1*(cy-my)*1*(cy-my)<= (r)*(r)
    End If
    #endmacro
    If b.mw=0 Then b.mw=1
    b.mw=Abs(b.mw)
    For x As Long=b.mx-40 To b.mx+40
        For y As Long=b.my-40 To b.my+40
            incircle(b.mx,b.my,40,x,y,a)
            If result Then
                clr=Point(x,y)
                _colour(x-b.mx+40,y-b.my+40)=Rgb(A_R(clr)*.95,A_G(clr)*.95,A_B(clr)*.95)
            End If
        Next y
    Next x
    Static As Single dil
    For x As Long=b.mx-40 To b.mx+40
        For y As Long=b.my-40 To b.my+40
            incircle(b.mx,b.my,40,x,y,a)
            If result Then
                rotate(b.mx,b.my,x,y,0,dil)
                Var dist=Sqr((b.mx-newx)*(b.mx-newx)+(b.my-newy)*(b.my-newy))
                dil=(b.mw+(.5-b.mw)*dist/(40*b.mw))
                Line(NewX-dil/2,NewY-dil/2)-(NewX+dil/2,NewY+dil/2),_colour(x-b.mx+40,y-b.my+40),BF
            End If
        Next y
    Next x
   End Sub
   
   Function Regulate(Byval MyFps As long,Byref fps As long) As long
    Static As Double timervalue,lastsleeptime,t3,frames
    Var t=Timer
    frames+=1
    If (t-t3)>=1 Then t3=t:fps=frames:frames=0
    Var sleeptime=lastsleeptime+((1/myfps)-T+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=T
    Return sleeptime
End Function

Screen 20,32
Dim As Any Ptr i,bt,sc,bck,bcki
sc=Imagecreate(1024,768,Rgb(128,50,0))
bck=Imagecreate(1024,768,Rgb(0,100,250))
bcki=Imagecreate(300,200)
Draw bcki,szz
Line bck,(0,500)-(1024,768),Rgb(0,0,100),bf

For x As Long=0 To 1024 Step 10
    Line sc,(x,0)-(x,768),Rgb(70,25,0)
    Next
i=Imagecreate(300,200,Rgb(0,100,200))
bt=Imagecreate(50,100)
Line i,(0,150)-(300,200),Rgb(0,0,100),bf
For k As Long=-5 To 5
    Line i,(k,k)-(300+k,200+k),Rgb(50+5*k,40,0),b
Next k
Circle sc,(750,400),100,Rgb(255,0,255),,,,f
For k As Single=-5 To 5 Step .01
    Circle sc,(750,400),100+k,Rgb(148+5*k,50,0)
Next k
 Circle sc,(750,400),105,Rgb(0,50,0)
 thickline(650,430,650,370,15,Rgb(20,10,0),sc)
 thickline(750,290,755,310,4,Rgb(130,10,0),sc)
 thickline(750,490,755,510,4,Rgb(130,10,0),sc)
 thickline(355,550,655,550,8,Rgb(0,100,0),sc)
 thickline(359,550,355,650,8,Rgb(50,10,0),sc)
 thickline(651,550,651,650,8,Rgb(50,10,0),sc)

Draw i,zz
Draw bt,b
Put sc,(300,250),i,Pset
Dim As Long fps,mx,my
Dim As Single a,k=1,dx,grad
Dim As d2 bb


Dim As v2 p1=Type(200,700),p2=Type(800,700),rot1,rot2,pt
Do
    Getmouse mx,my
    a+=.01*k
    dx+=1
    If a>.3 Or a <-.3 Then k=-k
    rot1=r2d(1024\2,768\2,p1.x,p1.y,-Sin(a*5)/5)
    rot2=r2d(1024\2,768\2,p2.x,p2.y,-Sin(a*5)/5)
   
    bb=Type(mx+25,my+60,1.5,0)
   
Screenlock
    Cls
    Put(0,0),bck,Pset
    Put (780-240+dx,340),bcki,Alpha,50
    If dx>440 Then dx=0
    rotateimage(,sc,Sin(a*5)/5,0,0,2,Rgb(255,0,255),1)

grad=Atn(-(rot1.y-rot2.y)/(rot1.x-rot2.x))
  pt=shortline(Type((rot1.x+rot2.x)/2,(rot1.y+rot2.y)/2),rot2,grad*1000-a)
rotateimage(,bt,Sin(a*5)/5,pt.x,pt.y-100,1,Rgb(255,0,255),1)

'Draw String(50,50),"fps  "&fps
thickline(rot1.x,rot1.y,rot2.x,rot2.y,14,Rgb(20,10,0))
bb=Type(pt.x+25,pt.y-40,1.5,0)
throughview(bb,2)
Screenunlock
Sleep regulate(15,fps),1
Loop Until Len(Inkey)
Imagedestroy bt
Imagedestroy i
Imagedestroy sc
Imagedestroy bck
Imagedestroy bcki
Sleep
 
srvaldez
Posts: 2550
Joined: Sep 25, 2005 21:54

Re: Squares

Postby srvaldez » Jan 09, 2020 14:23

Hi dodicat
very nice, just two questions: how did you construct the zz string?
I mean, did you use some kind of utility or did you do it by hand?
why the statement szz="S1"+Rtrim(zz,"S2") ?
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Toggle-Zip

Postby albert » Jan 09, 2020 18:22

Another compression formula...

it iterates a toggle and if the toggle = the bit then it outputs the toggle else it outputs a "00"

n1 = mid( bits , a , 1 )

if toggle = 0 then toggle = 1 else toggle = 0

if toggle = val( n1 ) then
outs+= n1
else
outs+= "00"
end if

You got to search for the double 0's

Can it be undone???

Code: Select all


' Binary Data Compressor ( BDC )

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
            '    if inkey = chr( 27 ) then end
            '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
   
    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) ' , chrs
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( chrs[ a - 1 ] )
        n1 = right( n1 , 8 )
        bits+=n1
    next
   
    print "c bit = " ; len( bits ) , bits
   
    dim as string outs = ""
    dim as ubyte toggle = 1
    for a as longint = 1 to len( bits ) step 1
       
        n1 = mid( bits , a , 1 )
       
        if toggle = 0 then toggle = 1 else toggle = 0
       
        if toggle = val( n1 ) then
            outs+= n1
        else
            if toggle = 0 then outs+= "00"
            if toggle = 1 then outs+= "00"
        end if
       
    next
   
    print "c out = " ; len( outs ) , outs
   
    dim as ubyte count = 0
    dim as string str1
    dim as ubyte dec1
    do
        str1 = str( len( outs ) / 8 )
        dec1 = instr( 1 , str1 , "." )
        if dec1 <> 0 then outs+= "0" : count+= 1
    loop until dec1 = 0
   
    dim as string final = ""
    for a as longint = 1 to len( outs ) step 8
        final+= chr( val( "&B" + mid( outs , 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
    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
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( chrs[ a - 1 ] )
        n1 = right( n1 , 8 )
        bits+= n1
    next
    bits = left( bits , len( bits ) - count )
   
    print "d bit = " ; len( bits ) , bits
   
    print "c tog = " ; len( bits ) ,
    dim as ubyte toggle = 1
    for a as longint = 1 to len( bits ) step 1
        if toggle = 0 then toggle = 1 else toggle = 0
        print toggle;
    next
    print
   
    return chrs
   
end function

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

Mod-Zip

Postby albert » Jan 09, 2020 20:55

Never mind!!
You can't tell a 0 - 00 from a 00 - 0

========================================
Here's another compressor... "Mod-Zip" ( Test-Bed )

It does cascading mods...
10,000 and under expands

100,000 compresses 79%
1,000,000 compresses 95%
========================================

Each set of n2 , ends in a "0" , so you can tell them apart..

v = 8 bit input

n2 = ""
if v > 127 then n2+= "0"
v1 = v mod 128

if v1 > 63 then n2+="1"
v2 = v1 mod 64

if v2 > 31 then n2+="10"
v3 = v2 mod 32

if v3 > 15 then n2+="11"
v4 = v3 mod 16

if n2 = "" then n2 = "00"

outs1+= right( "0000" + bin( v4 ) , 4 )

outs2+= n2 + "0"



Code: Select all


' Binary Data Compressor ( BDC )

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
            '    if inkey = chr( 27 ) then end
            '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
   
    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) ' , chrs
   
    dim as string bits = ""
    dim as string zeros = string( 8 , "0" )
    dim as string n1
    for a as longint = 1 to len( chrs ) step 1
        n1 = zeros + bin( chrs[ a - 1 ] )
        n1 = right( n1 , 8 )
        bits+=n1
    next
   
    print "c bit = " ; len( bits ) , bits
   
    dim as string outs1 = ""
    dim as string outs2 = ""
    dim as longint v , v1 , v2 , v3 , v4
    dim as string n2
    for a as longint = 1 to len( bits ) step 8
       
        n1 = mid( bits , a , 8 )
       
        v = val( "&B" + n1 )
       
        n2 = ""
       
        if v > 127 then n2+= "0"
        v1 = v mod 128
       
        if v1 > 63 then n2+="1"
        v2 = v1 mod 64
       
        if v2 > 31 then n2+="10"
        v3 = v2 mod 32
       
        if v3 > 15 then n2+="11"
        v4 = v3 mod 16
       
        if n2 = "" then n2 = "00"
       
        outs1+= right( "0000" + bin( v4 ) , 4 )
       
        outs2+= n2 + "0"
       
    next
   
    print "c out = " ; len( outs1 ) , outs1
    print "c out = " ; len( outs2 ) , outs2
   
    dim as ubyte count1 = 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" : count1+= 1
    loop until dec1 = 0

    dim as ubyte count2 = 0
    dim as string str2
    dim as ubyte dec2
    do
        str2 = str( len( outs2 ) / 8 )
        dec2 = instr( 1 , str2 , "." )
        if dec2 <> 0 then outs2+= "0" : count2+= 1
    loop until dec2 = 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+= "END"
    for a as longint = 1 to len( outs2 ) step 8
        final+= chr( val( "&B" + mid( outs2 , 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
    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 longint place = instr( 1 , chrs , "END" ) - 1
   
    dim as string bits1 = left( chrs , place )
    dim as string bits2 = mid( chrs , place + 4 )
   
    dim as string zeros = string( 8 , "0" )
    dim as string n1
   
    dim as string outs1 = ""
    for a as longint = 1 to len( bits1 ) step 1
        n1 = zeros + bin( bits1[ a - 1 ] )
        n1 = right( n1 , 8 )
        outs1+= n1
    next
    outs1 = left( outs1 , len( outs1 ) - count1 )
   
    dim as string outs2 = ""
    for a as longint = 1 to len( bits2 ) step 1
        n1 = zeros + bin( bits2[ a - 1 ] )
        n1 = right( n1 , 8 )
        outs2+= n1
    next
    outs2 = left( outs2 , len( outs2 ) - count2 )
   
    print "d bit = " ; len( outs1 ) , outs1
    print "d bit = " ; len( outs2 ) , outs2
       
   
    return chrs
   
end function

dodicat
Posts: 6728
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Postby dodicat » Jan 09, 2020 21:43

srvaldez wrote:Hi dodicat
very nice, just two questions: how did you construct the zz string?
I mean, did you use some kind of utility or did you do it by hand?
why the statement szz="S1"+Rtrim(zz,"S2") ?

Hi srvaldez.
Thanks for testing.
I made a small editor a while back (When member Quark was experimenting).
We haven't heard from Quark for four years!
He was a bit of an expert on strings and draw.
The "S2" was the original scale (my enlargement), reverting back to "S1" the default.
srvaldez
Posts: 2550
Joined: Sep 25, 2005 21:54

Re: Squares

Postby srvaldez » Jan 10, 2020 0:09

Hi dodicat
shouldn't be szz="S1"+Ltrim(zz,"S2") ?
is your editor posted somewhere on this forum ?
dodicat
Posts: 6728
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Postby dodicat » Jan 10, 2020 0:59

Indeed srvaldez.
Ltrim yes, but it was a mistake which came back as OK because the mess room interior was scaled up by two by the rotator, and the image outside the port hole was now scaled at "S1S2", the original, picking up "S2" instead of the "S1"
Thanks, I was lucky to get away with that, but when I saw the ghost ship sailing by outside I was happy enough not to check.
Here is the editor I use.

Code: Select all


'Mouse driven point to point editor.
'Press esc to end with choice of saving.
'right click screen to undo an instruction
dim as string bitmap= "bob.bmp"'if bitmap is valid it will load
dim as integer bitmapFlag
dim as string d
Dim Shared As Integer xres,yres
#define shaped 16
#define alphablend 64
#define OnTop 32
#define GetWindowHandle 2
Screeninfo xres,yres
'xres=800
'yres=600
Screenres int(.9*xres),int(.9*yres),32,,SHAPED Or ALPHABLEND Or ONTOP

Type v2
    As Integer x,y
    col As Ulong
    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
declare function FileLen alias "fb_FileLen" ( byval filename as zstring ptr ) as longint
declare function FileExists alias "fb_FileExists" ( byval filename as zstring ptr ) as integer
dim as any ptr bitmapim
if FileExists(bitmap) then
    bitmapflag=1
    var sz=size(bitmap)
     bitmapim=imagecreate(sz.x,sz.y)
    bload bitmap,bitmapim
    end if

Dim Shared As Integer monitorX,monitorY
Dim Shared As Integer WinposX,WinposY
Screeninfo monitorX,monitorY
'set up for opaque screen
Extern "windows" Lib "user32"
Declare Function GetDC Alias "GetDC" (Byval As Any Ptr) As Any Ptr
End Extern
Extern "windows" Lib "gdi32"
Declare Function _point Alias "GetPixel"(Byval As Any Ptr,Byval As Integer,Byval As Integer) As Ulong
End Extern
Declare Function SLWA Alias "SetLayeredWindowAttributes" (Byval As Any Ptr, Byval As Uinteger, Byval As Ubyte, Byval As Integer) As Integer
Declare Function NoConsole Alias "FreeConsole"  As Integer
Declare Function _getmouse Alias "GetCursorPos" (Byval As Any Pointer) As Integer
declare function showconsole alias "AllocConsole"() as integer


Sub BlendWindow( Byval Alpha_Value As Ubyte )
    Dim Win As Any Ptr
    var Ip = Cptr(Integer Ptr,@Win )
    Screencontrol GETWINDOWHANDLE, *Ip
    SLWA Win,Rgba(255,0,255,0),Alpha_Value,2 Or 1
End Sub
'---------------------------------------
Type Point
    As Single x,y,r
    As Integer counter
    As Ulong col
End Type
Type screenpoint
    As long x,y
End Type
Sub getmoose(Byref mx As Integer,Byref my As Integer,byref mb as integer=0,byref mw as integer=0)
    getmouse mx,my,mw,mb
    #define _map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
    ScreenControl 0, WinposX,WinposY
    Dim As screenpoint mouse=Type<screenpoint>(mx,my)
    _getmouse(@mouse)
    mx=_map(0,MonitorX,mouse.x-WinposX,0,MonitorX)
    my=_map(0,monitorY,mouse.y-WinposY,0,MonitorY)
End Sub
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
#define inpoint(c,mx,my) (mx)>(c.x-c.r) And (mx)<(c.x+c.r) And (my)>(c.y-c.r) And (my)<(c.y+c.r)
#define Red(col)   cptr(ubyte ptr,@col)[2]
#define Green(col) cptr(ubyte ptr,@col)[1]
#define Blue(col)  cptr(ubyte ptr,@col)[0]
dim shared as integer sx=50,sy=50 'screen start position


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 else 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
        sx=x-dx:sy=y-dy
        pressed=0
        Exit Sub
    End If
    lastmx=mx:lastmy=my
End Sub


sub traceover(a() as point, col as ulong,l as integer,im as any ptr=0)
    for n as integer=l to ubound(a)-1
        line im,(a(n).x,a(n).y)-(a(n+1).x,a(n+1).y),col
        next n
    end sub
   
Dim As Point c(1 To 5)         'the four boxes on top
Redim As Point Ccolours(0)     'the coloured boxes below
Redim As Point s(0)           'the array running parallel(Legacy from an older program, but still handy)
Dim As Point slide(1 To 3)    'the colour slider circles

Dim As Any Pointer im=imagecreate(.9*xres,.9*yres,Rgb(0,0,0))
Screeninfo xres,yres
Dim As Any Ptr MyScreen = GetDC(0)
'slider ball circles
slide(1).y=.92*yres:slide(1).r=5:slide(1).col=Rgb(200,0,0)
slide(2).y=.94*yres:slide(2).r=5:slide(2).col=Rgb(0,200,0)
slide(3).y=.96*yres:slide(3).r=5:slide(3).col=Rgb(0,0,200)

'the three larger circles
c(1).x=.3*xres:c(1).y=20:c(1).r=10
c(2).x=.5*xres:c(2).y=20:c(2).r=10
c(3).x=.9*xres:c(3).y=20:c(3).r=10
c(4).x=.7*xres:c(4).y=20:c(4).r=10
c(5).x=.1*xres:c(5).y=25:c(5).r=10
'=========  DRAW STUFF TO AN IMAGE ================
'The colour boxes
dim as string border=Str(Rgb(0,200,0))',lastborder,starter
Line im,(0,0)-(xres,50),Rgb(100,100,255),bf
Dim As Integer ypos=.9*yres
Dim As Integer _st=.4*xres/25
Dim As Ulong col,tally,total,delta1
Line im,(0,.9*yres)-(xres,yres),Rgb(100,100,255),bf
Line im,(.6*xres,.92*yres)-(.75*xres,.92*yres),Rgb(200,0,0)
Line im,(.6*xres,.94*yres)-(.75*xres,.94*yres),Rgb(0,200,0)
Line im,(.6*xres,.96*yres)-(.75*xres,.96*yres),Rgb(0,0,200)
For y As Integer=_st To 4*_st Step _st
    tally+=1
    For x As Integer=.1*xres To .5*xres Step _st
        total+=1
        delta1=map((.1*xres),(.5*xres),x,0,254)
        Select Case tally
        Case 1: col=Rgb(255,delta1,0)
        Case 2:col=Rgb(0,255,delta1)
        Case 3:col=Rgb(delta1,0,255)
        Case 4:col=Rgb(255-delta1,255-delta1,255-delta1)
        End Select
        Redim Preserve Ccolours(1 To total)
        Ccolours(total)=Type<Point>(x,ypos+y-_st,_st,0,col)
        Line im,(x-_st/2,ypos-_st/2+y)- (x+_st/2,ypos+_st/2+y),col,bf
        Line im,(x-_st/2,ypos-_st/2+y)- (x+_st/2,ypos+_st/2+y),rgb(0,0,0),b
    Next x
Next y

'================= GRID AND CIRCLES =======================
For x As Integer=0 To xres Step 50
    Line im,(x,50)-(x,yres),Rgba(255,255,255,200)'50 before
Next x
For y As Integer=50 To yres Step 50
    Line im,(0,y)-(xres,y),Rgba(255,255,255,200)
Next y
For z As Integer=1 To 4
    line im,(c(z).x-c(z).r,c(z).y-c(z).r)-(c(z).x+c(z).r,c(z).y+c(z).r),Rgb(255,255,255),b
    'Circle im,(c(z).x,c(z).y),c(z).r+1,Rgb(255,255,255)
Next z
if bitmapflag=1 then line im,(c(5).x-c(5).r,c(5).y-c(5).r)-(c(5).x+c(5).r,c(5).y+c(5).r),Rgb(255,255,255),b
Line im,(0,.9*yres)-(xres,.9*yres),Rgb(0,200,0)
Draw String im,(c(1).x-150,c(1).y),"NEW POINTS -->"
Draw String im,(c(2).x-80,c(2).y),"FILL -->"
Draw String im,(5,5), "SCREEN RESOLOTIONS = " &xres-1 &"," &yres-1
Draw String im,(.9*xres-50,35),"SCREEN TOGGLE"
Draw String im,(.7*xres-70,35),"SEE THROUGH TOGGLE"
if bitmapflag=1 then
Draw String im,(.1*xres-70,40),"BITMAP TOGGLE"
end if

'================  IMAGE NOW DRAWN =========================

Noconsole        'hide the dos box
'===============================================
'some variables
Dim As Integer mx,my,mb,flag1,flag2,flag3,flag4,flag5,flag6,flag7,toggle=1,counter,paintflag,contrast=1
dim as integer flag8,bitmaptoggle=1
Dim As Integer dx,dy
Dim As String key
Dim As String fill=Str(Rgb(255,255,255))
dim as string delta,first
d="""C"+border+"B" +d

Dim As String f=d
Dim As Integer count,cm,z
Dim As Integer rd,gr,bl,lower=1
Dim As Ulong boxcol=valulng(fill),circ1col,circ2col
dim as integer bitmapx=0,bitmapy=50,bflagx,bflagy
counter=0
'========================  SHOW THE SCREEN =================
#macro showscreen()
Screenlock
Cls
Put(0,0),im,alpha
if bitmaptoggle=1 then
if bitmapflag then put(bitmapx,bitmapy),bitmapim,pset
end if
'highlight the newpoints box
line(c(1).x+c(1).r-1,c(1).y+c(1).r-1)-(c(1).x-c(1).r+1,c(1).y-c(1).r+1),circ1col,bf

'draw the colour slider circles
For z As Integer=1 To 3
    Circle(slide(z).x,slide(z).y),slide(z).r,slide(z).col,,,,f
Next z
'highlight the fill circle
Circle(c(2).x,c(2).y),c(2).r-1,circ2col,,,,f
circle(c(3).x,c(3).y),c(3).r-1,circ2col
'the coloured square
Line(.8*xres,.9*yres)-(.85*xres,.95*yres),boxcol,bf
'top and base of drawing area
Line (0,.9*yres)-(xres,.9*yres),valuint(border)
line (0,50)-(xres,50),valuint(border)
Draw String(xres/3,60),"mouse " & mx &"   " & my
Draw String(xres/2,60),"Previous mouse " &s(Ubound(s)).x & "  " &s(Ubound(s)).y
'the rbg values of the fill colour shown
Draw String(.8*xres,.975*yres),"RGB(" &RED(boxcol) &"," &GREEN(boxcol) &"," & BLUE(boxcol) &")",Rgb(255,255,255)

Draw d  'MAIN STRING

traceover(s(),boxcol,lower)
'small spot at mouse
pset (s(Ubound(s)).x,s(Ubound(s)).y)
 if contrast=1 then line(0,50)-(xres,.9*yres),rgba(0,0,0,150),bf

Screenunlock
Sleep 1,1
#endmacro
'=============================================================

Do
   
    getmoose(mx,my,mb)
    key=Inkey
    cm=0
    'Set the slider bobs to match the fill colour (boxcol)
    slide(1).x=map(0,255,RED(boxcol),(.6*xres),(.75*xres))
    slide(2).x=map(0,255,GREEN(boxcol),(.6*xres),(.75*xres))
    slide(3).x=map(0,255,BLUE(boxcol),(.6*xres),(.75*xres))
   
    'colours highlight at mouse inside(Two boxes at the top, not the toggle)
    circ1col=Rgb(100,100,255)
    circ2col=Rgb(100,100,255)
    'arrow keys to shift the screen
    if bflagx=0 and bflagy=0 then
    If key=Chr(255)+"K" Then sx-=5:bflagx=1
    If key=Chr(255)+"M" Then sx+=5:bflagx=1
    If key=Chr(255)+"P" Then sy+=5:bflagy=1
    If key=Chr(255)+"H" Then sy-=5:bflagy=1
    end if
    if len(key)=0 then bflagx=0:bflagy=0
    if bitmapflag=0 then
    screencontrol 100,sx,sy
    'bflag=0
    else
   if bflagx then bitmapx+=sgn(sx-50)*5:sx=50
   if bflagy then bitmapy+=sgn(sy-50)*5:sy=50
    end if
    'CHECK THE MOUSE IN:
    If mb=1 And flag6=0 Then   'the colours in the boxes at the bottom
        flag6=1
        For z =1 To Ubound(Ccolours)
            If inpoint(Ccolours(z),mx,my+5)=0 Then boxcol=Ccolours(z).col':border=str(boxcol)
        Next z
    End If
    flag6=mb
   
    For cm=Lbound(c) To Ubound(c) 'Check for mouse in a box (upper screen)
        If inpoint(c(cm),mx,my) Then Exit For
        If my>.9*yres Then cm=-1: Exit For
    Next cm
   
    If cm=5 and bitmapflag=1 Then 'BITMAP TOGGLE
        If mb=1 And flag8=0 Then
            flag8=1
            bitmaptoggle=-bitmaptoggle
        End If
    End If
    flag8=mb
   
   
    If cm=4 Then 'CONTRAST TOGGLE
        If mb=1 And flag7=0 Then
            flag7=1
            contrast=-contrast
        End If
    End If
    flag7=mb
   
    If cm=3 Then 'SCREEN TOGGLE
        If mb=1 And flag5=0 Then
            flag5=1
            toggle=-toggle
            If toggle=-1 Then blendwindow(100) Else blendwindow(255)
        End If
    End If
    flag5=mb
   
    If cm=2 And Ubound(s)>=3 Then 'FILLER
        If PaintFlag Then circ2col=boxcol
        If mb=1 And flag4=0 Then
            flag4=1
            fill= Str(boxcol)
           'var t=ltrim(starter ,"""C")
           If PaintFlag  Then d+="P"+fill+","+border't'str(boxcol)'border
        End If
    End If
    flag4=mb
   
    If cm=1 Then         'NEW START
        circ1col=Rgb(0,200,0)
        If mb=1 And flag3=0  Then
            flag3=1
             lower=ubound(s)+1
            d+=""""+"_"+Chr(10)+"&"+""""
            d+="B"
        End If
    End If
    flag3=mb
    If my<50 And cm=Ubound(c)+1 then moveall:cm=0 'if mouse in top frame
    'CREATE THE STRING FOR DRAW.
    'AND CREATE AN ARRAY IN PARALLEL
    If mb=1 And flag1=0 And cm=Ubound(c)+1 Then
        flag1=1:counter+=1
        Redim Preserve s(1 To Ubound(s)+1)
        s(Ubound(s))=Type<Point>(mx,my,0,counter)
        Dim As Integer dx,dy
        If counter=1 Then dx=mx:dy=my Else  dx=mx-s(Ubound(s)-1).x:dy=my-s(Ubound(s)-1).y
        If counter=1 Then d+="M"+Str(dx)+","+Str(dy) Else d+="M+"+Str(dx)+","+Str(dy)
        count+=1
        If count>5 Then d+=""""+"_"+Chr(10)+"&"+"""":count=0
    End If
    flag1=mb
   
    'go back on right mouse click(delete mistakes)
    If mb=2 And flag2=0 Then
        flag2=1
        If counter>1 Then Redim Preserve s(1 To Ubound(s)-1):counter-=1
        If counter=1 Then Redim s(0):counter=0
        delta=Mid(d,instrrev(d,"M"))
        d=Rtrim(d,delta)
    End If
    flag2=mb
   
    showscreen()
   
    'the colour sliders
    For z As Integer=1 To 3 'in the colour sliders
        If inpoint(slide(z),mx,my) Then
            While mb = 1
                Getmouse mx,my,,mb
                showscreen()
                If mx<>slide(z).x Or my<>slide(z).y  Then
                    rd=RED(boxcol):gr=GREEN(boxcol):bl=BLUE(boxcol)
                    slide(z).x=mx
                    If slide(z).x<.6*xres Then slide(z).x=.6*xres
                    If slide(z).x>.75*xres Then slide(z).x=.75*xres
                    Select Case As Const z
                    Case 1: rd=map((.6*xres),(.75*xres),slide(1).x,0,255)
                    Case 2: gr=map((.6*xres),(.75*xres),slide(2).x,0,255)
                    Case 3: bl=map((.6*xres),(.75*xres),slide(3).x,0,255)
                    End Select
                    If rd<0 Then rd=0:If rd>255 Then rd=255
                    If gr<0 Then gr=0:If gr>255 Then gr=255
                    If bl<0 Then bl=0:If bl>255 Then bl=255
                    boxcol=Rgb(rd,gr,bl)
                End If
            Wend
        End If
    Next z
  If Len(d)-Instrrev(d,"B")<18 Then PaintFlag=1 Else PaintFlag=0
Loop Until key =Chr(27)
d+=""""
screeninfo xres,yres
dim as any ptr lastscreen=imagecreate(xres,yres,0)
get(0,0)-(xres-1,yres-1),lastscreen
dim as string q
screenres xres,yres,32
put(0,0),lastscreen,pset
draw string(100,100),"Do you wish to save -- y/n",rgb(255,255,255)
var ff=freefile
do
 q=input(1)
loop until lcase(q)="n" or lcase(q)="y"
if lcase(q)="n" then goto fin

locate 6,6
if Open ("DRAWINGpoints.bas" For Output As #ff)=0 then print "saved":beep else print "Fail"
Print #ff,"Dim as string zz = _"
Print #ff,d

Print #ff,"'Number off points ";Ubound(s)

Print #ff,"Screenres ";xres;",";yres;",";32
Print #ff, "Draw zz"
Print #ff,"Sleep"
Close #ff

shell "notepad DRAWINGpoints.bas"
Sleep
fin:
imagedestroy im
imagedestroy lastscreen
if bitmapim<>0 then imagedestroy bitmapim
 
 

 

Member Quark thought it was too tricky to use, but I find it easy enough, I suppose because I made it up.
You can see a bitmap if it is valid, line 5.
To paint an area, make sure it is enclosed properly, put a new point inside the area, choose a colour and fill.
You can edit the final saved string to tweak the starting position for example, the first "BM".
All the rest of the points are relative.
You can add "S2" for example to scale up.
You can change the border colours by editing the string.

Basiccoder2 also wrote an editor for draw, I think a bit better than mine.
His used absolute points, but you can run the final string through a process to create relative points.
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Postby albert » Jan 10, 2020 3:50

It works with minus as well...

for a as longint = 1 to len( chrs ) step 1
v = chrs[ a - 1 ]
n1 = ""
if v > 127 then v-= 128 : n1+= "0"
if v > 063 then v-= 064 : n1+= "1"
if v > 031 then v-= 032 : n1+= "10"
if v > 015 then v-= 016 : n1+= "11"
if n1 = "" then n1 = "00"
bits1+= right( "0000" + bin( v ) , 4 )
bits2+= n1 + "0"
next

But you can have a 10 , and a 10110 , so you can't tell them apart.

It compresses ; because some sets are 2 or 3 bits out , instead of 4...
00
10
100
110
010
000

Got to find a set that works , and can be told apart from each other...
srvaldez
Posts: 2550
Joined: Sep 25, 2005 21:54

Re: Squares

Postby srvaldez » Jan 10, 2020 11:23

thank you dodicat :-)

Return to “General”

Who is online

Users browsing this forum: No registered users and 6 guests