Sample codes from the 1k coding contest

[pistol350]

Edit : Just a reminder of the short speech that i wrote previously just to affect you PROGRAMMERS   

Yeah Guys!
It's a pity any Coding competion is not organised among us anymore.
Competions like the 1K coding competition were so!!!!
It just gives me the impression that people no longer code for fun and only for busines purpose , a big shame 
Anyway, just have a look to the great examples we could see when Coders coded for fun 

Peter B.

Hey Krypt!
This one was nice too!
Free space Monitor by Krypt

Code Select Expand


def NOFC,TNOC,SPC,BPS:uint64:DEF FB,TB:double:DEF mwin:window
DECLARE "Kernel32",GetDiskFreeSpaceA(RootPathName:string,lpSectorsPerCluster:pointer,lpBytesPerSector:pointer,lpNumberOfFreeClusters:pointer,lpTotalNumberOfClusters:pointer),INT
DECLARE DS(drive:string)
WINDOW mwin,0,0,200,40,@SYSMENU|@toolwindow,0,"FreeSpace Monitor",win:CONTROL mwin,"T,,0,0,200,16,,1"::setcontrolcolor mwin,1,rgb(255,0,0),rgb(0,0,0):run = 1:waituntil run = 0:stoptimer mwin:closewindow mwin:end
sub win:select @class:case @idcreate:centerwindow mwin:starttimer mwin,500:case @idclosewindow:run = 0:case @idtimer:DS("c:\"):setcontroltext mwin,1,"                                    ":setcontroltext mwin,1,("C:\"+" = "+str$((FB)/1074988.8659793814432989690721649) + " MB FREE"):endselect:return
sub DS(drive):DEF res:int:DEF BPC:uint:DEF ptr,pSPC,pBPS,pNFC,pTNC:pointer:pSPC=SPC:pBPS=BPS:pNFC=NOFC:pTNC=TNOC:res=GetDiskFreeSpaceA(drive,pSPC,pBPS,pNFC,pTNC):BPC=(BPS*SPC):FB=(BPC*NOFC):TB=(BPC*TNOC):RETURN


[pistol350]

Another nice one by Zerodog

Code Select Expand

'Doodlepad by ZeroDog - 1k compo
def w:window:a=32770:b=0:c=255:d=16777215:x=0:l=0:y=0:m=0:t=1:j=0:k=0
WINDOW w,0,0,c,c,458752,0,"Doodlepad",q
frontpen w,c:setwindowcolor w,d
control w,"B,Color,0,0,50,20,0,1":control w,"B,Pen,50,0,50,20,0,3"
control w,"B,Line,100,0,50,20,0,2":control w,"B,Rect,150,0,50,20,0,4"
control w,"B,Clear,200,0,47,20,0,5":waituntil w=0:end
q::select @class:case a:closewindow w:case 513
f
g
if(t=3)|(t=4) then g
b=1:case 514
if(t=2):h :i :h :g :endif:if(t=3):i :n :endif
b=0:case 512
if(b=1):if(t=1):i :g :h :f :endif
if(t=2):if(l):u :h :g :h :endif:endif
if(t=3):u :n :n :g :endif:endif
case a+2:z=@controlid
if z=1:c=COLORREQUEST(w):if(c<0)then c=0:frontpen w,c:endif
if z=2 then t=2:if z=3 then t=1:if z=4 then t=3:if z=6 then t=4
if z=5:getscreensize j,k :rect w,0,0,j,k,d,d:endif
endselect
return
f:: x=@mousex:y=@mousey:return:g::l=@mousex:m=@mousey:return
h::LINE w,x,y,l,m,c:return:i::RASTERMODE w,13:return
u::RASTERMODE w,6:return:n::rect w,x,y,l-x,m-y,c,c:return


[pistol350]

Fractals by Jolly Roger

Code Select Expand


DEF w:WINDOW
DEF minlength:INT
DEF lenmult,angleoffset:FLOAT
DECLARE drawline(x:INT,y:INT,length:FLOAT,angle:FLOAT)
WINDOW w,0,0,640,480,@MINBOX|@MAXBOX,0,"Press a key to draw a fractal",mw
RECT w,0,0,640,480,0,0
WAITUNTIL w=0
END
SUB mw
SELECT @class
  CASE @IDCLOSEWINDOW
   CLOSEWINDOW w
  CASE @IDCHAR
   RECT w,0,0,640,480,0,0
   angleoffset=.5+RND(1):lenmult=.5+RND(.25):minlength=1
   IF lenmult>.6 THEN minlength=1+(lenmult-.6)*20
   FOR b=0 TO 2
     drawline(320,240,60,b*2.1)
   NEXT b
ENDSELECT
RETURN
SUB drawline(x,y,length,angle)
IF length>minlength
  SELECT FLOOR((length-INT(length))*5.99)
   CASE 0:c=0xFF:CASE 1:c=0xFFFF
   CASE 2:c=0xFF00:CASE 3:c=0xFF0000
   CASE 4:c=0xFFFF00:CASE 5:c=0xFF00FF
  ENDSELECT
  dx=length*SIN(angle):dy=length*COS(angle)
  LINE w,x,y,x+dx,y-dy,c
  branchx=x+dx:branchy=y-dy
  drawline(branchx,branchy,length*lenmult,angle+angleoffset)
  drawline(branchx,branchy,length*lenmult,angle-angleoffset)
ENDIF
RETURN


[pistol350]

By Jolly Roger again.
Have fun
small game with sound effect   LOL

Code Select Expand


DEF w:WINDOW:DEF ss:MEMORY:DEF byv,bxv,bx,by,obx,oby,m:FLOAT:DEF r,ox,x,t:INT:DEF s[2249]:CHAR
wh=0xFFFFFF
WINDOW w,0,0,640,480,16,0,"Click to start/blow.Keep balloon on screen",mw
s=82,73,70,70,193,8,0,0,87,65,86,69,"f","m","t",32,16,0,0,0,1
s[21]=0,1,0,17,43,0,0,17,43,0,0,1,0,8,0,"d","a","t","a",157,8,0,0
FOR db=44 TO 2248:s[db]=RND(255):NEXT db
ALLOCMEM ss,1,2249:WRITEMEM ss,1,s
STARTTIMER w,50:STARTTIMER w,1000,2
WAITUNTIL w=0
FREEMEM ss
END
SUB mw
SELECT @CLASS
CASE 32770:CLOSEWINDOW w
CASE 513
IF r=1
dx=x+5-bx
IF ABS(dx)<21
m=.25+by/400
byv=byv-(20-ABS(dx))*m*.25
bxv=bxv-dx*m*.17
ENDIF
PLAYWAVE ss,1
ELSE
r=1:bx=320:by=20:bxv=1:byv=5:t=0
ENDIF
CASE 512:x=@MOUSEX:RECT w,ox,435,9,20,wh,wh:RECT w,x,435,9,20,0,0:ox=x
CASE 275
IF r=1
IF @CODE=1
byv=byv*.99+.1
bxv=bxv*.99:bx=bx+bxv:by=by+byv:CIRCLE w,obx,oby,20,wh,wh:CIRCLE w,bx,by,20,255,255:obx=bx:oby=by
IF bx<-20|bx>654|by>475|by<-20 THEN r=0
ELSE
t=t+1:SETCAPTION w,STR$(t)
ENDIF
ENDIF
ENDSELECT
RETURN


[pistol350]

Fish by Jolly Roger

Code Select Expand

DEF w:WINDOW
DEF fc[5],fx[5],fs[5],c[6]:INT
c=0xFF,0xFF0000,0xFF00,0xFFFF,0xFF00FF,0xFFFF00
FOR f=0 TO 4
fx[f]=RND(600):fs[f]=4+RND(3):fc[f]=c[RND(6)]
NEXT f
WINDOW w,0,0,640,480,@MINBOX,0,"Fish",mw
SETFONT w,"webdings",100,500,0x20000
STARTTIMER w,50
SETWINDOWCOLOR w,0xFFA0A0
BACKPEN w,0xFFA0A0
WAITUNTIL w=0
END
SUB mw
SELECT @CLASS
  CASE @IDCLOSEWINDOW
   CLOSEWINDOW w
  CASE @IDTIMER
   FOR f=0 TO 4
    fx[f]=fx[f]-fs[f]:MOVE w,fx[f],f*100:FRONTPEN w,fc[f]:PRINT w,CHR$(244)
    IF fx[f]<-200:fx[f]=600+RND(100):fs[f]=4+RND(3):fc[f]=c[RND(6)]:ENDIF
    NEXT f
ENDSELECT
RETURN

[pistol350]

"Asc Viewer"  by Philippe.txt

Code Select Expand

def z:window
n="Arial":m="Asc Viewer - Font is : ":g=0xD0D0D0
def s,f,q:int
i=450:j=110:w=0x50000101
window z,0,0,600,i,@caption|@minbox|@maxbox,0,"",d
setcaption z,m+n:centerwindow z:setwindowcolor z,0xF0F0F0
CONTROL z,"T,,i,70,j,j,w,257":setfont z,"",64,500,0,257
CONTROL z,"B,Change Font,i,350,j,20,w,258":CONTROL z,"T,Asc :,i,180,j,20,w,259"
CONTROL z,"B,Close,i,375,j,20,w,260":for i=257 to 260:setcontrolcolor z,i,0,g:next i
for i=1 to 16:for j=1 to 16
r=(i-1)*16+j:CONTROL z,"T,,j*24-10,i*24-10,22,22,w,r"
setcontrolcolor z,r,0,g:setfont z,n,11,600,0,r:setcontroltext z,r,chr$(r)
next j:next i
waituntil z=0
end
d:
select @class
case @idclosewindow:closewindow z
CASE @idcontrol:j=@controlid
if j<257:setcontroltext z,259,"Asc :"+str$(j) :setcontroltext z,257,chr$(j):endif 
if j=258:n=FONTREQUEST(z,s,w,f,q)
if n<>""
for i=1 to 257:SETFONT z,n,11,w,f,i:setcontrolcolor z,i,q,g:next i
SETFONT z,n,60,w,f,257:setcaption z,m+n
endif
endif
if j=260 then closewindow z
endselect
return



[pistol350]

Memory game using Webdings by Philippe.txt

Code Select Expand


'Memory
e=500:j=400:l=32770:h=20:def w:window:def v[33],u[33]:int:c=60:g=40:k=l*3:t=0:q=0:m="Memory"
window w,0,0,530,350,0,0,m,d:centerwindow w:setwindowcolor w,0xff:for j=1 to 8:for i=1 to 4:r=(j-1)*4+i
CONTROL w,"T,s,j*(c+5)-c,i*(c+5)-c,c,c,257,r":setfont w,"webdings",g,e,k,r:setcontrolcolor w,r,0,0xfafafa
next i:next j:gosub z:CONTROL w,"B,New,10,280,70,20,0,50":f=2000000:waituntil w=0:end
d::select @class:case l:closewindow w:case l+2:c=@controlid:if c=50:gosub z:return:endif
if u[c]=1:return:else:if k=t:k=k+1:g=c:setcontroltext w,c,chr$(v[g]+70)
setcaption w,m+str$(k)+" tries":else:if g=c then return:t=t+1:setcontroltext w,c,chr$(v[c]+70)
if v[g]=v[c]:for e=1 to f:next e:setcontroltext w,c,"a":setcontroltext w,g,"a"
q=q+1:u[g]=1:u[c]=1:else:for e=1 to f:next e:setcontroltext w,g,"s":setcontroltext w,c,"s"
endif:endif:endif:endif:endselect:return:z::for i=1 to 32:v[i]=(i+1)/2:u[i]=0:next i
for i=1 to 32:h=rnd(33-i)+i:j=v[h]:v[h]=v[i]:v[i]=j:setcontroltext w,i,"s":next i:g=0:k=0:t=0:q=0:return


[pistol350]

United colors by Philippe.txt
World map using webdings blended with colour

Code Select Expand


'in the begining i wanted to make a kind of wargame .....
'the result is just a bit different !!!!
'to be sure to be on the picture just change until n=12000 to until n=6410555636 (line 24)
'( 23:45 french time)
'http://www.abacom.com/~pdescham/natmond.html
'( don't change it unless you want to have your pc not responding for 50 to 150 days -rough estimation-  )
'if the prog doesn't work try changing the line "if c=fp" to "if c-fp<8" -
'thanks to jolly roger)

' United Colors
def w:window
def col[5]:int
def n,x,y,hdc,bp,fp:int
z=""
bp=0xa00000
fp=bp+1
col[1]=0xffffff,0xff,0x00ffff,0
m="webdings"
window w,0,0,800,480,0x80CA0080,0,"",w1hnd
centerwindow w
CONTROL w,"B,Start,365,430,70,20,0,1"
gosub remplit
run=1
waituntil run=0
releasehdc(w,hdc)
closewindow w
end

w1hnd:
select @class
case @idcontrol
gosub remplit
enablecontrol w,1,0
n=0
setfont w,m,8,300,0x20000
drawmode w,@transparent
hdc=gethdc w
do
x=rnd(800):y=rnd(450)
c=getpixel (w,x,y)
if c=fp
move w,x-10,y-4
frontpen w,col[n%4+1]
print w,chr$(128+rnd(4+1))
n=n+1
endif
until n=12000
enablecontrol w,1,1
z=string$(40,"_")
setcaption w,z+"oo0o---Where is Charlie ?---o0oo"+z
case @idclosewindow
run=0
endselect
return
sub remplit
drawmode w,@opaque
backpen w,bp
frontpen w,fp
setfont w,m,480,500,0x20000:move w,-43,-80:print w,"ÃÆ'Ã,» "
return 


[pistol350]

Webdings viewer by Jolly Roger

Code Select Expand


AUTODEFINE "OFF"
DEF win:WINDOW
DEF run,zoom,white,column,row:INT
white=0xFFFFFF
WINDOW win,0,0,640,480,@MINBOX,0,"Webdings-click on one to enlarge",mainwindow
SETFONT win,"webdings",20,500,0x20000
run = 1
FOR c=0 TO 255
  MOVE win,32*(c%20),35*FLOOR(c/20):PRINT win,CHR$(c)
NEXT c
WAITUNTIL run=0
CLOSEWINDOW win
END

SUB mainwindow
SELECT @class
   CASE @IDCLOSEWINDOW
    run=0
   CASE @IDLBUTTONDN
      RECT win,0,0,640,480,white,white
      IF zoom=0
        SETFONT win,"webdings",300,500,0x20000
        zoom=1
        column=FLOOR(@MOUSEX/32):row=FLOOR(@MOUSEY/35):MOVE win,0,0:PRINT win,CHR$(row*20+column)
        SETCAPTION win,"Webding number"+STR$(row*20+column)+".Click to return to full list"
      ELSE
        SETFONT win,"webdings",20,500,0x20000
        FOR c=0 TO 255
          MOVE win,32*(c%20),35*FLOOR(c/20):PRINT win,CHR$(c)
        NEXT c
        SETCAPTION win,"Webdings-click on one to enlarge"
        zoom=0
      ENDIF
ENDSELECT
RETURN