## Old Demo from Amstrad CPC 6128 Disk's

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
jepalza
Posts: 110
Joined: Feb 24, 2010 10:08
Location: Spain (Bilbao)

### Old Demo from Amstrad CPC 6128 Disk's

For Amstrad CPC users nostalgic, like me...

Code: Select all

``````Dim PI As Single = 3.14156
Dim i As Integer = 1
Dim T(3) As Integer

Dim s As single

Dim F As Integer = 1
Dim g As Integer

Dim A As Integer
Dim B As Integer
Dim C As integer

SCREEN 12

T(1) = 63 * 65536 + 0 * 256 + 0
T(2) = 0 * 65536 + 50 * 256 + 50
T(3) = 0 * 65536 + 0 * 256 + 50
PALETTE 1, T(1)
PALETTE 2, T(2)
PALETTE 3, T(3)

FOR s = 0 TO 4 * PI STEP PI / 60
PSET (320 + (320 * SIN(s / 2)), 200 + (198 * COS(s)))
LINE -(320 + (200 * COS(s / 2)), 200 + (198 * SIN(s))), i
i = i + 1: IF i = 4 THEN i = 1
NEXT

While InKey\$<>Chr\$(27)
If F = 1 THEN A = 1: B = 2: C = 3
If F = 2 THEN A = 3: B = 1: C = 2
If F = 3 THEN A = 2: B = 3: C = 1
Palette 1, T(A)
Palette 2, T(B)
Palette 3, T(C)
F = F + 1: IF F = 4 THEN F = 1
Sleep 200
Wend
``````
D.J.Peters
Posts: 8460
Joined: May 28, 2005 3:28
Contact:

### Re: Old Demo from Amstrad CPC 6128 Disk's

yes retro feelings

here are CPC on green monitor

Joshy

Code: Select all

``````dim as long iWidth,iHeight,iPitch
screeninfo iWidth,iHeight ' get screen size
iWidth *=0.75 ' make it a bit smaller
iHeight*=0.75
screenres iWidth,iHeight,8,2 ' setup two pages
screenset 1,0 ' one work page and one visible page

palette 0,0,48,0 ' darg green as background color
for i as long=1 to 255
' from darg green to bright green
palette i,0,48+i/1.5,0
next
' get current dimension and the pitch of one line
screeninfo iWidth,iHeight,,,iPitch

dim as single x(1),y(1),sx(1),sy(1)
for i as integer = 0 to 1
x(i)=rnd*iWidth ' random x,y position of he line
y(i)=rnd*iHeight
sx(i)=3+rnd*5 ' random x,y speed of the line
sy(i)=3+rnd*3
next

while inkey()=""
' fade out all pixels by 1 to dark green
dim as ubyte ptr row=screenptr()
for y as integer=1 to iHeight
dim as ubyte ptr pixel=row
for x as integer=1 to iWidth
if *pixel>0 then *pixel-=1
pixel+=1 ' next pixel
next
row+=iPitch ' next row
next
' draw the line in bright green
line (x(0),y(0))-(x(1),y(1)),255
' animate the line
for i as integer=0 to 1
' x,y position + x,y speed if x or y goes out the screen reverse the speed direction (*-1)
x(i)+=sx(i): if x(i)<0 orelse x(i)>=iWidth  then sx(i)*=-1:x(i)+=sx(i)
y(i)+=sy(i): if y(i)<0 orelse y(i)>=iHeight then sy(i)*=-1:y(i)+=sy(i)
next
flip ' make the work page visible
sleep 10
wend
``````
jdebord
Posts: 543
Joined: May 27, 2005 6:20
Location: Limoges, France
Contact:

### Re: Old Demo from Amstrad CPC 6128 Disk's

There is a project named "Crocodile Basic" on the PANORAMIC Basic forum to revive the CPC BASIC, using FB as the compiler.

https://panoramic.1fr1.net/f38-crocodile-basic

It's all in french, though.
jepalza
Posts: 110
Joined: Feb 24, 2010 10:08
Location: Spain (Bilbao)

### Re: Old Demo from Amstrad CPC 6128 Disk's

jdebord wrote: May 12, 2022 7:10 There is a project named "Crocodile Basic" on the PANORAMIC Basic forum to revive the CPC BASIC, using FB as the compiler.

https://panoramic.1fr1.net/f38-crocodile-basic

It's all in french, though.
How work it? With DLL?
I has one program (my only commercial game for CPC "abracadabra" from "proein softline" 1987) that i want to convert to Fb.

( https://www.cpc-power.com/index.php?page=detail&num=716 )
dodicat
Posts: 7444
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: Old Demo from Amstrad CPC 6128 Disk's

Far memory.
Click run to start.

Code: Select all

``````
Type Point
As Single x,y,z
As Ulong col
As Single dx,dy
As Single kx,ky
End Type
#define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)

Function spline(p() As Point,t As Single) As Point
#macro set(n)
0.5 *(     (2 * P(2).n) +_
(-1*P(1).n + P(3).n) * t +_
(2*P(1).n - 5*P(2).n + 4*P(3).n - P(4).n) * t*t +_
(-1*P(1).n + 3*P(2).n- 3*P(3).n + P(4).n) * t*t*t)
#endmacro
Return Type<Point>(set(x),set(y),set(z))
End Function

Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
Static As Double timervalue,lastsleeptime,t3,frames
frames+=1
If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
Var sleeptime=lastsleeptime+((1/myfps)-Timer+timervalue)*1000
If sleeptime<1 Then sleeptime=1
lastsleeptime=sleeptime
timervalue=Timer
Return sleeptime
End Function

Sub GetCatmull(v() As Point,outarray() As Point,colour As Ulong,arraysize As Long=1000)
Dim As Point p(1 To 4)
Redim outarray(0)
Dim As Single stepsize=(Ubound(v)-1)/(arraysize)
If stepsize>1 Then stepsize=1
For n As Long=2 To Ubound(v)-2
p(1)=v(n-1):p(2)=v(n):p(3)=v(n+1):p(4)=v(n+2)
For t As Single=0 To 1 Step stepsize
Redim Preserve outarray(1 To Ubound(outarray)+1)
outarray(Ubound(outarray))=spline(p(),t)
outarray(Ubound(outarray)).col=colour+Rnd*1000-Rnd*1000
Next t
Next n
End Sub

Sub DrawCurve(a() As Point,ydisp As Long=0)
Pset(a(Lbound(a)).x,a(Lbound(a)).y+ydisp),a(Lbound(a)).col
For z As Long=Lbound(a)+1 To Ubound(a)
Line-(a(z).x,a(z).y+ydisp),a(z).col
Next z
End Sub

Function lngth(a() As Point) As Long
Dim As Long acc
For n As Long=Lbound(a) To Ubound(a)-1
acc+=Abs(a(n).x-a(n+1).x) + Abs(a(n).y-a(n+1).y)
Next n
Return acc
End Function

Sub _line(x1 As Integer,y1 As Integer,x2 As Integer,y2 As Integer,l As Integer,col As Ulong,Byref xp As Integer=0,Byref yp As Integer=0)
Dim As Integer diffx=x2-x1,diffy=y2-y1,ln=Sqr(diffx*diffx+diffy*diffy)
If ln=0 Then ln=1e-6
Dim As Single nx=diffx/ln,ny=diffy/ln
xp=x1+l*nx:yp=y1+l*ny
Line(x1,y1)-(xp,yp),col
End Sub
Sub Bmouse(mx As Integer,my As Integer,sz As Integer)
Dim As Integer xp,yp
Dim As Ulong c=Rgb(255,255,250)
_line(mx,my,mx+sz,my+.8*sz,sz,c,xp,yp)
_line(xp,yp,mx+sz/2,yp+.03*sz,.4*sz,c,xp,yp)
Var tx=xp,ty=yp
_line(mx,my,mx,my+1.2*sz,sz,c,xp,yp)
_line(xp,yp,mx+sz/2,yp-sz/2,.4*sz,c,xp,yp)
_line(xp,yp,mx+sz/2,yp+sz/2,sz,c,xp,yp)
_line(xp,yp,xp+sz/2,yp-.4*sz,.2*sz,c,xp,yp)
_line(xp,yp,tx,ty,.95*sz,c,xp,yp)
Paint(mx+.1*sz,my+.2*sz),c,c
End Sub

Randomize 1
Screen 20,32,,64

Dim As Point v(1 To 10)
Redim As Point C()
For n As Long=1 To Ubound(v)-2
v(n)=Type(Rnd*800,500+Rnd*100,Rnd*200)
v(n).kx=.01:v(n).ky=.01
Next n
v(Ubound(v)-1)=Type(400,300,0)
v(Ubound(v))=Type(400,200,0)
Getcatmull(v(),C(),Rgb(0,100,255),900)

Dim As Long L= lngth(C())/2
Dim As Single kx=2,ky=-2
Dim As Single dd=.1
Dim As Long fps',dist
Dim As Single dist

Dim As Any Ptr i=Imagecreate(1024,768)
Line i,(0,0)-(1024,20),Rgb(168,168,168),bf
Draw String i,(30,5),"File",Rgb(0,0,0)
Draw String i,(30+70,5),"Edit",Rgb(0,0,0)
Draw String i,(30+140,5),"View",Rgb(0,0,0)
Draw String i,(30+210,5),"Search",Rgb(0,0,0)
Draw String i,(30+290,5),"Run",Rgb(0,0,0)
Draw String i,(30+350,5),"Debug",Rgb(0,0,0)
Draw String i,(30+430,5),"Calls",Rgb(0,0,0)
Draw String i,(30+500,5),"Options",Rgb(0,0,0)
Draw String i,(950,5),"Help",Rgb(0,0,0)
Line i,(0,20)-(1024,768),Rgb(0,0,168),bf
Line i,(10,25)-(1015,760),Rgb(255,255,255),b
Line i,(0,745)-(1025,768),Rgb(0,168,168),bf
Line i,(1015,35)-(1015,710-170),Rgb(0,0,168)
Draw String i,(20,750)," <Shift+F1=Help>    <F6=Window>    (F2=Subs>    <F5=Run>    <F8=Step>     ",Rgb(0,0,0)
For n As Long = 35 To 700-170 Step 16
Draw String i,(1010,n),Chr(176),Rgb(168,168,168)
Next
Line i,(1010,33)-(1018,53),Rgb(168,168,168),bf
Draw String i,(1010,33),Chr( 24 ),Rgb(0,0,0)
Line i,(1010,700-170)-(1018,720-170),Rgb(168,168,168),bf'bx
Draw String i,(1010,700-170),Chr( 25 ),Rgb(0,0,0)
Line i,(1010,53)-(1018,73),Rgb(0,0,0),bf
Var g=String(124, Chr(176) )'219
Draw String i,(20,550),g
Line i,(10,580)-(512-55,580),Rgb(168,168,168)
Line i,(512+55,580)-(1024-10,580),Rgb(168,168,168)
Draw String i,(512-40,573),"Immediate"
Line i,(10,550)-(30,565),Rgb(168,168,168),bf
Line i,(30,550)-(50,565),Rgb(0,0,0),bf
Draw String i,(15,550),Chr(27),Rgb(0,0,0)
Line i,(1000-10,550)-(1020-10,565),Rgb(168,168,168),bf
Draw String i,(1000,550),Chr(26),Rgb(0,0,0)
Draw String i,(750,750-6),"|",Rgb(0,0,0)
Draw String i,(750,750+2),"|",Rgb(0,0,0)
Draw String i,(800,750),Time,Rgb(0,0,0)
Dim As Long mx,my,btn
Do
Screenlock
Cls
Getmouse mx,my,,btn

If (mx>320 And mx<340 And my>4 And my<20) And btn Then
Line i,(0,0)-(1024,768),Rgb(255,0,255),bf
Screenunlock
Exit Do
End If
Put(0,0),i,Pset
bmouse(330,15,18)
Screenunlock
Sleep 1
Loop
Dim As String key
Do
Screenlock
Line(0,0)-(1023,767),Rgba(0,0,0,2),bf
v(Ubound(v)-1).x+=kx
v(Ubound(v)-1).y+=ky

If v(Ubound(v)-1).x<-50 Or v(Ubound(v)-1).x>1075  Then kx=-kx
If v(Ubound(v)-1).y<-50  Or v(Ubound(v)-1).y>818 Then ky=-ky

For n As Long=1 To Ubound(v)-1
v(n).dx=(v(n+1).x-v(n).x)
v(n).dy=(v(n+1).y-v(n).y)
v(n).x+=v(n).kx*v(n).dx/(dd*(kx)):v(n).y+=v(n).ky*v(n).dy/(dd*(kx))
If v(n).x<0  Or v(n).x>1024 Then v(n).kx=-v(n).kx
If v(n).y<0 Or v(n).y>768 Then v(n).ky=-v(n).ky
Next n

Var clr=map(1000,5000,dist,50,200)
Getcatmull(v(),C(),Rgb(clr,100,255),900)
dist=lngth(c())/(1+Rnd)
If dist>l Then kx-=.001:ky-=.001
If dist<l Then kx+=.001:ky+=.001

drawcurve(C())
Put(0,0),i,trans
Screenunlock
key=Inkey
Sleep regulate(50,fps)
Loop Until key=Chr(27) Or key=Chr(255)+"k"
Imagedestroy i

``````
Last edited by dodicat on May 13, 2022 13:08, edited 1 time in total.
jdebord
Posts: 543
Joined: May 27, 2005 6:20
Location: Limoges, France
Contact:

### Re: Old Demo from Amstrad CPC 6128 Disk's

jepalza wrote: May 12, 2022 19:20 How work it? With DLL?

https://www.unilim.fr/pages_perso/jean. ... bcroco.htm

There is a DLL which implements several procedures in FB for most of the CPC commands (MODE, ORIGIN, PEN, PAPER, MOVE, PLOT ...)

But it is not an emulator. You will have to adapt the original Amstrad code.
jdebord
Posts: 543
Joined: May 27, 2005 6:20
Location: Limoges, France
Contact:

### Re: Old Demo from Amstrad CPC 6128 Disk's

For those who need only the Amstrad graphics, I have made a specific library :

amsgraph.zip

It's a static library, distributed as source code, with english documentation and 15 sample programs.

jepalza
Posts: 110
Joined: Feb 24, 2010 10:08
Location: Spain (Bilbao)

### Re: Old Demo from Amstrad CPC 6128 Disk's

good

Looks similar to my CPC emu
viewtopic.php?p=272508&hilit=cpc+emulator#p272508
jdebord
Posts: 543
Joined: May 27, 2005 6:20
Location: Limoges, France
Contact:

### Re: Old Demo from Amstrad CPC 6128 Disk's

Thank you jepalza

I will check the emulator. It would be nice to convert some of these old BASIC games to FB, using the library.