AmiBlitz³ - Snippets & Libraries

simple vectorstars

Sat, 20 Jan 2024 21:33:53 +0100

eine möglichkeit "vectorstars" zu basteln (unoptimiert)

1-bitplane screen, rotiert 3 achsen, sin/cos vorberechnet, ausführbar mit aktueller amiblitzversion

Code:
Statement xCls{a.l}

  MOVE.l d0,a0 : ADD.l #40*256,a0

  MOVEQ #0,d0 : MOVEQ #0,d1 : MOVEQ #0,d2  : MOVEQ #0,d3  : MOVEQ #0,d4

  MOVEQ #0,d5 : MOVEQ #0,d6 : MOVE.l d0,a1 : MOVE.l d0,a2 : MOVE.l d0,a3

  MOVE #255,d7

  loop1:MOVEM.l d0-d6/a1-a3,-(a0):DBRA d7,loop1

  AsmExit

End Statement

BitMap 0,320,256,1

BitMap 1,320,256,1

AGAPalRGB 0,0,32,22,33

AGAPalRGB 0,1,200,200,200

NEWTYPE.ball

x.q

y

z

nx

ny

End NEWTYPE

Dim List balls.ball(50)

While AddLast(balls())

  balls()\x=Rnd(40)-20

  balls()\y=Rnd(40)-20

  balls()\z=Rnd(40)-20

Wend

distance.w = 20

Dim Costable(360)

Dim Sintable(360)

For i=0 To 359

Costable(i)=Int( Cos(i*0.017453) *1024 )

Sintable(i)=Int( Sin(i*0.017453) *1024 )

Next

BLITZ

InitCopList 0,44,256,$10001,8,2,0

Mouse On

CreateDisplay 0

DisplayBitMap 0,0:DisplayPalette 0,0

Use BitMap db

While Joyb(0)=0

  VWait

  DisplayBitMap 0,db

  db=1-db

  Use BitMap db

  xCls{Peek.l (Addr BitMap(db)+8)}

 vx + 2; X rotation speed

 vy + 1; Y rotation speed

 vz + 1; Z rotation speed

 If vx>359:vx=1:EndIf

 If vy>359:vy=1:EndIf 

 If vz>359:vz=1:EndIf

 distance=10+MouseY

  cosx=Costable(vx)

  cosy=Costable(vy)

  cosz=Costable(vz)

  sinx=Sintable(vx)

  siny=Sintable(vy)

  sinz=Sintable(vz)

ResetList balls()

While NextItem(balls())

;simply move stars

  balls()\x+1

  If balls()\x>20 Then balls()\x=-20

;"3d-engine" ^^

  ty = ((balls()\y * cosx) - (balls()\z * sinx))/1024

  tz = ((balls()\y * sinx) + (balls()\z * cosx))/1024

  tx = ((balls()\x * cosy) - (tz * siny))/1024

  tz = ((balls()\x * siny) + (tz * cosy))/1024

  balls()\nx  = ( 200 * tx) / (distance - tz )  + 160

  balls()\ny  = ( 200 * ty) / (distance - tz)   + 127

  nodraw=0

  If balls()\nx > 319 : nodraw=1 : EndIf

  If balls()\ny > 255 : nodraw=1 : EndIf

  If balls()\nx < 1   : nodraw=1 : EndIf

  If balls()\ny < 1   : nodraw=1 : EndIf

  If nodraw=0

  Plot balls()\nx,balls()\ny,1

  EndIf  

  Wend

Wend

End

Barnsley fern fractal

Sun, 26 Feb 2023 16:16:19 +0100

This is a fun to do fractal with lots of numbers to play with for diffferent results.

You can read more about the algorithm and example code here:

https://en.wikipedia.org/wiki/Barnsley_fern

This is a quick implementation in BlitzBasic.

Code:
WbToScreen1

num.l=1000000    ;number of iterations

Window1,0,0,ScreenWidth,ScreenHeight,$140F,"Barnsley fern fractal. it="+Str$(num),2,1

ResetTimer

x.q     = 0

y.q     = 0

nextX.q = 0

nextY.q = 0

originX =  ScreenWidth / 2

s = Min( ScreenWidth, ScreenHeight ) / 10

For i.l = 1 To num

     a.q = Rnd

     If a.q < 0.01

          nextX.q = 0

          nextY.q = 0.16 * y.q

     Else

        If a.q >= 0.01 AND a.q < 0.08

              nextX.q = 0.2 * x.q - 0.26 * y.q

              nextY.q = 0.23 * x.q + 0.22 * y.q + 1.6

        Else

          If a.q >= 0.08 AND a.q < 0.15

              nextX.q = -0.15 * x.q + 0.28 * y.q

              nextY.q = 0.26 * x.q + 0.24 * y.q + 0.44

          Else

              nextX.q = 0.85 * x.q + 0.04 * y.q

              nextY.q = -0.04 * x.q + 0.85 * y.q + 1.6

          EndIf

        EndIf

     EndIf

     x.q = nextX.q

     y.q = nextY.q

     WPlot x.q * s + originX, y.q * s,1

Next

Print Ticks," ticks"

Repeat

Until WaitEvent=$200   ;windowclose

End

and this is how it looks like:

fern_bb2.png (Größe: 196,17 KB / Downloads: 1143)

Protracker Module Header

Mon, 18 Jan 2021 22:28:17 +0100

Ich hatte mal ein altes Tool gemacht, mit dem man ganze Verzeichnisse nach MODs absuchen konnte, rekursiv.

Da letztens im EAB Forum die Frage aufkam, wie man an die Samples kommt, hier mal als Erstes zum Einstieg die Aufdröselung der Samples, noch ohne die eigentlichen Daten, die sind am Ende nach den Patterns.
Hoffe, das hilft jemandem:

Code:
Dim mtyp$(5)

mtyp$(1)="ProTr"

mtyp$(2)="SoundTr"

mtyp$(3)="NoiseTr"

mtyp$(4)=""

mtyp$(5)="?(PPack)"

DEFTYPE.l

#typoffset=$438    ;=1080

c$=Chr$(10)

Function.w checkmod{f$}

result.b=0:real$=""

fhand.l=Open_(f$,1005)

If fhand>0

  buf.l=AllocMem_($500,#MEMF_PUBLIC|#MEMF_CLEAR)

  If buf>0

    Read_ fhand,buf,$500

    Close_ fhand

    If Mkl$(Peek.l(buf))="PP20"

      result=5

    Else

      md$=Mkl$(Peek.l(buf+#typoffset))

      Select md$

        Case"M.K.":result=1

          real$=Left$(Peek$(buf),20)

          NPrint "-------------- ",f$," --------------"

          NPrint "name: ",real$

          Gosub getsamp

        Case"FLT4":result=2

        Case"M&K!":result=3

      End Select

    EndIf

    FreeMem_ buf,$500

  Else

    result=0:Close_ fhand:Goto ex

  EndIf

Else

  result=0;:Goto ex

EndIf

ex:Function Return result

getsamp:

  NPrint"Samples:"

  ssize.w=30 ;sample info block size

  snums.w=30 ;

  spos.w  =20  ;start sib`s

  For n.w=0 To snums  ;#=31

    dum$=PeekToStr(buf+spos,0,22)

    dsz.w=Peek.w(buf+spos+22) *2   ;size in bytes

    Format"#0":Print Str$(n),": "

    Format""

    If dum$<>""

      NPrint LSet$(dum$,23)," > ",Str$(dsz)

    Else

      NPrint LSet$("",23)," > ",Str$(dsz)

    EndIf

    spos + ssize

  Next

  Format""

Return

End Function

Aufrufen der Funktion mit

Code:
typ = checkmod {"path/filename"}

nprint mtyp$(typ)

007.png (Größe: 256,54 KB / Downloads: 1818)

Für mehr braucht man eigentlich nur die 'ptmodformat' Dokumentation, oder z.B:
https://githup.com/raspi/trackermod

Man sollte aber natürlich Grundkenntnisse haben, das hilft.

Hier noch schnell die Executables.

Checkmod_test.lha (Größe: 9,23 KB / Downloads: 1)

Checkmod03.lha (Größe: 6,28 KB / Downloads: 1)

bPaint (AMOS Recreation) mit Src

Sun, 06 Sep 2020 19:36:50 +0200

Ich hab hier mal einen alten Sourcecode ausgebuddelt. Den hatte ich letztes Jahr oder so nochmal angefaßt zwecks Bugfixes oder so.

Kann vielleicht als hilfreiches Beispiel dienen.

Das ist in keinem Falle als ausgereiftes, fertiges Programm anzusehen!

bpaint_grab.jpg (Größe: 68,68 KB / Downloads: 1904)

Code:
.

.rev

;################################################################################

;#                                                                              #

;#  Source     :    bpaint_sys.bb                                         #

;#                                                                              #

;#  Description:    recreation of AMOS paint (unfinished)                                                #

;#                                                                              #

;#  Author     :    Frank Brandis                                               #

;#                                                                              #

;#  Exec       :    Blitz2:Execs/Foo                                            #

;#                                                                              #

;#  Date of                                                                     #

;#  Creation   :                                                                #

;#                                                                              #

;#  Date of                                                                     #

;#  Update(s)  :                                                                #

;#                                                                              #

;#                                                                              #

;#  To do      :                                                                #

;#                                                                              #

;#                                                                              #

;################################################################################

;

.his

;################################################################################

;#                                                                              #

;#  History    :                                                                #

;#                                                                              #

;#                                                                              #

;################################################################################

;

.

;################################################################################

;

;gadgets, modes

#up         =1

#down       =2

#left       =3

#right      =4

#tobuffer   =5

#frombuffer =6

#insertframe=7

#deleteframe=8

#playanim   =9

#save       =10

#load       =11

#freihand   =12

#bogen      =13

#linie      =14

#rechteck   =15

#ellipse    =16

#text       =17

#lupe       =18

#cut        =19

#rotier     =20

#flipx      =21

#flipy      =22

#clear      =23

#undo       =24

#info       =25

;windows

#picwin   =2

#toolwin  =1

#palwin   =3

#zoomwin  =4

NEWTYPE.box

 x.w

 y.w

 w.w

 h.w

End NEWTYPE

DEFTYPE.box statbar   ;statusbar

statbar\x=0,22,36*8+12,10

Dim palpen.box(32)     ;dims are added within drawpal{}

DEFTYPE.w

Dim modetxt$(30)

Read nummodes

For i=1 To nummodes

  Read modetxt$(i)

Next

Data.w 25

Data.s "up","down","left","right","tobuffer","frombuffer"

Data.s "insertframe","deleteframe","playanim","save"

Data.s "load","freihand","bogen","linie","rechteck","ellipse"

Data.s "text","lupe","cut","rotier","flipx","flipy","clear","undo","info"

MaxLen pa$=450

MaxLen fi$=180

.funcs

Statement clrstatus {col.w}

 SHARED statbar.box

 ;Use Window #toolwin

 USEPATH statbar

 WBox \x+1,\y+1,\x+\w-1,\y+\h-1,col

 USEPATH ycy

End Statement

Statement drawstatus {}

 SHARED statbar.box

 Use Window #toolwin

 USEPATH statbar

 ;border

 Wline \x,\y+\h,\x,\y,\x+\w,\y,2

 Wline \x+\w,\y,\x+\w,\y+\h,\x,\y+\h,4

 USEPATH ycy

End Statement

Statement status {txt$,col.w}

 SHARED statbar.box

 Use Window #toolwin

 USEPATH statbar

 clrstatus {3}

 WindowOutput1

 WLocate \x+3,\y+2

 WColour col,3

 Print   txt$

 USEPATH ycy

End Statement

Statement drwstatus{mode.w}

 SHARED nummodes.w

 SHARED modetxt$()

 If mode >0 AND mode<=nummodes

   status{">"+modetxt$(mode)+"<",1}

 Else

   status{"?",7}

 EndIf

End Statement

Statement drawrect{x1,y1,x2,y2,col}

 Wline x1,y1,x2,y1,x2,y2,x1,y2,x1,y1,col

End Statement

Statement newscreen{wid.w,heid.w,dep.w,mode.l}

  SHARED d,w,h

  If w<320 Then w=320

  If h<256 Then h=256

  Screen #picwin,0,0,wid,heid,dep,mode,"",0,0

  ScreensBitMap #picwin,0

  ShowPalette #picwin

  d=dep:w=wid:h=heid

  Window #picwin,0,0,w,h,$800,"",1,0

  MenusOff

  Use BitMap 0:Cls

End Statement

CNIF0       ;vertical

Statement openpal{}

 SHARED palstatus.b

 If palstatus=0

   Use Screen #picwin

   Window #palwin,0,0,14,ScreenHeight,$802,"p",0,0

   palstatus=1

 EndIf

End Statement

Statement drawpal{}

  Use Window #palwin

  WCls

  wh=212

  ws=wh/32

  c=0

  For gy=0 To wh Step ws

    WBox 0,gy,14,gy+ws-1,c

    c+1

  Next

End Statement

CEND

Statement openpal{}

 SHARED palstatus.b

 If palstatus=0

   Use Screen #picwin

   Window #palwin,0,0,ScreenWidth,14,$800,"",0,0

   palstatus=1

 EndIf

End Statement

Statement drawpal{}

  SHARED palpen.box()

  Use Window #palwin

  WCls

  ww=WindowWidth

  ws=ww/32

  c=0

  For gx=0 To ww Step ws

    WBox gx,0,gx+ws-1,14,c

    palpen(c)\x=gx,y,ws-1,14

    c+1

  Next

End Statement

Function.w palhit {x.w,y.w}

  SHARED palpen.box()

  res.w=-1

  c=0

  USEPATH palpen(c)

  Repeat

    If RectsHit (x,y,1,1,\x,\y,\w,\h)

      res=c

    EndIf

    c+1

  Until c>32 OR res=>0

  USEPATH vxxx

  Function Return res ; -1 = FAIL !

End Function

._setup

AddIDCMP$10

AutoCookie On

;Format"00"

For gad=1To25

; LoadShape gad,"bpaintshps/bpaintshape."+Str$(gad),0

; LoadShape gad+25,"bpaintshps/bpaintshape."+Str$(gad+25),0

  InitShape gad,10,10,2

  InitShape gad+25,10,10,2

Next

;Format""

;SaveShapes1,50,"bpaint.shps"

;SavePalette0,"bpaint.pal"

LoadShapes1,"BlitzINC:_dat/bpaint.shps"

LoadPalette #toolwin,"BlitzINC:_dat/iff/bpaint.br"

LoadPalette #picwin,"ENV:dpaint32.col"

ShapeGadget 0,010,00,0  ,#up         ,01,1+25

ShapeGadget 0,010,11,0  ,#down       ,02,2+25

ShapeGadget 0,000,06,0  ,#left       ,03,3+25

ShapeGadget 0,020,06,0  ,#right      ,04,4+25

ShapeGadget 0,030,00,0  ,#tobuffer   ,05,5+25

ShapeGadget 0,068,00,0  ,#frombuffer ,06,6+25

ShapeGadget 0,106,00,0  ,#insertframe,07,7+25

ShapeGadget 0,144,00,0  ,#deleteframe,08,8+25

ShapeGadget 0,182,00,0  ,#playanim   ,09,9+25

ShapeGadget 0,263,00,0  ,#save       ,10,10+25

ShapeGadget 0,292,00,0  ,#load       ,11,11+25

ButtonGroup1

ShapeGadget 0,  0,33,512,#freihand   ,12,12+25:Toggle0,12,On

ShapeGadget 0, 19,33,512,#bogen,13   ,13+25   :Disable0,#bogen

ShapeGadget 0, 38,33,512,#linie,14   ,14+25

ShapeGadget 0, 57,33,512,#rechteck   ,15,15+25

ShapeGadget 0, 76,33,512,#ellipse    ,16,16+25

ShapeGadget 0, 95,33,512,#text       ,17,17+25:Disable0,#text

ShapeGadget 0,133,33,512,#cut        ,19,19+25

ShapeGadget 0,114,33,1  ,#lupe       ,18,18+25

ShapeGadget 0,152,33,0  ,#rotier     ,20,20+25

ShapeGadget 0,171,33,0  ,#flipx      ,21,21+25

ShapeGadget 0,190,33,0  ,#flipy      ,22,22+25

ShapeGadget 0,263,33,0  ,#clear      ,23,23+25

ShapeGadget 0,282,33,0  ,#undo       ,24,24+25

ShapeGadget 0,301,22,0  ,#info       ,25,25+25

LoadFont1,"Fiona.font",8

w.w=320

h.w=256

newscreen{w,h,5,0}

Screen #toolwin,0,211,320,45,3,0,"",0,0

ShowPalette #toolwin

RGB7,15,2,1

Window #toolwin,0,0,320,45,$1000|$800,"",0,0,0 ;toolbox

WindowFont1

MenusOff

WBox0,0,320,43,3:For gad=1To25:Redraw1,gad:Next gad

drawstatus{}

status{"Welcome to bPaint",7}

Delay_50

;Gosub getname

frontcol.w=1

backcol.w =0

drawcol=1

drawmod.b=#freihand

drwstatus{#freihand}

exit=0

.

.main

Repeat

 ev.l=WaitEvent

 If EventWindow=#picwin

   Select ev

     Case$10

       If frontpen=-1           ;brush

         wx=WMouseX:wy=WMouseY

         WJam3

         drawrect{wx-rx,wy-ry,wx+rx,wy+ry,frontcol}

         WaitTOF_

         drawrect{wx-rx,wy-ry,wx+rx,wy+ry,frontcol}

         WJam0

       EndIf

     Case$8

       Use Window #picwin

       oldx=WMouseX:oldy=WMouseY

       Select MButtons

         Case2

       ;    drawcol=backcol

           Gosub dodraw

         Case1

       ;    drawcol=frontcol

           Gosub dodraw

       End Select

     Default

       Gosub intuicodes

   End Select

 Else

   Gosub intuicodes

 EndIf

Until exit

CloseWindow #picwin:CloseWindow #toolwin

Free BitMap0

CloseScreen #picwin:CloseScreen #toolwin

End

.

.dodraw

   Select drawmod

     Case#freihand

       While Joyb(0)>0

         wx=WMouseX:wy=WMouseY

         If frontpen<>-1

           WPlot wx,wy,drawcol

           Wline oldx,oldy,wx,wy,drawcol

           oldx=wx:oldy=wy

         Else

           Use BitMap0

           ClipBlit0,wx,wy

         EndIf

       Gosub updatelup

       Wend

     Case#linie

       While Joyb(0)>0

         wx=WMouseX:wy=WMouseY

         WJam3

         Wline oldx,oldy,wx,wy,drawcol

         VWait:Wline oldx,oldy,wx,wy,drawcol

       Wend

       WJam0

       Wline oldx,oldy,wx,wy,drawcol

     Case#rechteck

       While Joyb(0)>0

         wx=WMouseX:wy=WMouseY

         WJam3

         drawrect{oldx,oldy,wx,wy,drawcol}

         VWait:drawrect{oldx,oldy,wx,wy,drawcol}

       Wend

       WJam0

         drawrect{oldx,oldy,wx,wy,drawcol}

     Case#ellipse

       While Joyb(0)>0

         wx=WMouseX:wy=WMouseY

         WJam3

         xrad=QAbs(oldx-wx):yrad=QAbs(oldy-wy)

         WEllipse oldx,oldy,xrad,yrad,drawcol

         VWait:WEllipse oldx,oldy,xrad,yrad,drawcol

       Wend

       WJam0

       WEllipse oldx,oldy,xrad,yrad,drawcol

     Case#cut

       While Joyb(0)>0

         wx=WMouseX:wy=WMouseY

         WJam3

         drawrect{oldx,oldy,wx,wy,drawcol}

         VWait:drawrect{oldx,oldy,wx,wy,drawcol}

       Wend

       WJam0

       If wx
       If wy
       If wx=oldx OR wy=oldy Then Goto cute

       GetaShape0,oldx,oldy,wx-oldx,wy-oldy

       MakeCookie0

       sw=ShapeWidth(0)

       sh=ShapeHeight(0)

       rx=sw/2:ry=sh/2

       Handle0,rx,ry

       frontpen=-1

       cute:

   End Select

Return

.

.intuicodes

 Select ev

._mbut

   Case$8

     If EventWindow=#palwin

       res=palhit{WMouseX,WMouseY}

       If res>-1

         drawcol=res

         status{"col="+Str$(drawcol),1}

         Use Window #palwin

       EndIf

     EndIf

   Case$40

._gads

     Select GadgetHit

       Case #up

       Case #down

       Case #left

       Case #right

       Case #tobuffer

       Case #frombuffer

       Case #insertframe

       Case #deleteframe

       Case #playanim

       Case #save

       Case #load        :Gosub loadpic

       Case #freihand    :drawmod=#freihand

       Case #bogen

       Case #linie       :drawmod=#linie

       Case #rechteck    :drawmod=#rechteck

       Case #ellipse     :drawmod=#ellipse

       Case #text

       Case #lupe:If GadgetStatus(0,#lupe)Then Gosub openlup Else Gosub closelup

       Case #cut         :drawmod=#cut

       Case #rotier

       Case #flipx

       Case #flipy

       Case #clear

         ;Use BitMap0:Cls backcol

         Use Window #picwin:WCls

       Case #undo

       Case #info

     End Select

     drwstatus{drawmod}

   Case$400

._keys

     ev$=LCase$(Inkey$)

     Select ev$

       Case Chr$(27):exit=1   ;QUIT

       Case "p"

         If palstatus=0

           uwin=Used Window

           openpal{}

           drawpal{}

           Activate #picwin: Use Window #picwin

         Else

           CloseWindow #palwin:palstatus=0

           Use Window uwin

         EndIf

      ;   status{"Palette not implemented",7}

      ;   Delay_50

      ;   drwstatus{drawmod}

     End Select

 End Select

Return

.

.loadpic

 FindScreen0,"board"

 g$=ASLFileRequest$("name of picture to load",pa$,fi$,pat$)

 If g$<>""

   If ILBMInfo(g$)

     FlushEvents$400000

     VWait12

     CloseWindow #picwin

     VWait12

     Free BitMap0

     VWait12

     CloseScreen #picwin

     VWait12

     newscreen{ILBMWidth,ILBMHeight,ILBMDepth,ILBMViewMode}

     LoadBitMap0,g$,#picwin:ShowPalette #picwin

   EndIf

 EndIf

Return

.

.openlup

 Use Screen #picwin

 Window #zoomwin,w/2,14,w/2,h-14-45,$800,"",0,0

 WCls 1

; BitMap 1,320,256,d

; BitMap 2,320,256,d

Return

.closelup

; Free BitMap1

; Free BitMap2

 CloseWindow#zoomwin

 Use Window #picwin

Return

.updatelup:

;  Use BitMap 1: BitMapOutput1                        ;do actual zooming!

;  x=xm-azoom3 : y=ym-bzoom3                        ;subtract zoom width/height

;  If x<0 Then x=0                                      ;check for off screen

;  If y<0 Then y=0

;  If x>w-azoom Then x=w-azoom

;  If y>h-bzoom Then y=h-bzoom

;  Use BitMap0

;  Scroll x,y,azoom,bzoom,0,0,0                         ;grab the block

;  azoom2.w=azoom+8                                     ;increase to make

;  If azoom>320 Then azoom=320                          ; sure window will be full

;  ????? 1,2,0,0,azoom2,bzoom                      ;do X4

;  Use Window 0

;  BitMaptoWindow 2,2,0,0,0,0,windwmod,windh               ;copy zoom into window

;  windw.w=w/2

;  windh.w=h

;  windwmod.w=windw-(windw MOD zoom)

;  azoom.w=(windw)/4

;  bzoom.w=(windh)/4

;  azoom3=azoom ASR 1

;  bzoom3=bzoom ASR 1

Return

NoCli:CloseEd:WBStartup

bpaint_assets.lha (Größe: 4,71 KB / Downloads: 1)

Argument in String Parsing, rekursiv

Sun, 10 Nov 2019 19:20:32 +0100

Ich habe mal ein simples Beispiel vorbereitet, das einzelne Teile aus einem String herauslöst. Man kann das z.B. benutzen als Argumentparser, Wortzähler usw..

Es nutzt hier nur Leerzeichen als Trenner, man kann das aber natürlich anpassen auf ganze Strings von Worttrennern, wenn man will.

Code:
;CMD parse test by f.brandis

;

DEFTYPE.w

;parsetest cmds

cmd$="dump from %s to           %d    a b cde 4 6 jj m , . ."

NPrint ">",cmd$,"<"

Function.w stripnparse{inp$}         ;recursive!

  SHARED nums

  inp$=StripLead$(inp$,32)           ;strip leading SPC

  If inp$="" Then Function Return0   ;nothing left!

  spc1.w=Instr(inp$," ")             ;another separator?

  If spc1>1                          ;any SPC at the end of this inp$?

    arg1$=Mid$(inp$,spc1)

    out$ =Left$(inp$,spc1-1)

    Gosub _strpnprsprt

    ok=stripnparse{arg1$}            ;down the rabbit hole...

  Else                               ;rest is an arg.

    out$=inp$

    Gosub _strpnprsprt

  EndIf

  Function Return nums               ;global count

_strpnprsprt:

  nums+1

  NPrint "Arg"+Str$(nums)+": >",out$,"<"

Return

End Function

NPrint "#args: ",stripnparse{cmd$}

MouseWait

End

CloseEd

argparse_example.png (Größe: 116,19 KB / Downloads: 1988)

Lemmings-like multi-obj

Sat, 19 Oct 2019 01:45:19 +0200

Hier mal ein Beispiel für eine Multi-Objekt (lemmings-like) Verwaltung(sehr simpel!).

WTF Wo ist mein Anhang?? Warum kann ich kein LHA anhängen??

lemms419.png (Größe: 143,78 KB / Downloads: 2041)

Code:
;My Own Lemmings!!!!!

;-By F.Brandis

WBStartup:NoCli:CloseEd

BitMap1,320,256,4:BitMap0,320,256,4

dr$="blitzinc:_dat/"

LoadShapes0,dr$+"Lemms.shp"

dr$="blitzinc:_dat/iff/"

LoadBitMap0,dr$+"LemLev_b.iff",0

dr$="blitzinc:_dat/sfx/"

LoadSound0,dr$+"Lemm-Letsgo.sfx"

LoadSound1,dr$+"Lemm-Aehh!.sfx"

CopyBitMap0,1

VWait50

BLITZ

Slice0,44,4

Show0:Use Palette0

NEWTYPE.lemming

lemx.w

lemy.w

lemm.b       ;frame

dir.b

fall.b

bcount.b  ;new: bouncecount

End NEWTYPE

DEFTYPE.w

lan.b=40

Dim List l.lemming(lan)

USEPATH l()

While AddItem(l())

  Gosub randomlem

Wend

Buffer0,(lan+1)*50*5

Buffer1,(lan+1)*50*5

Sound0,15

Repeat

Show db.b:db=1-db:Use BitMap db

VWait:UnBuffer db

;o.b+1:If o>100Then Sound1,15:o=0

ResetList l()

While NextItem(l())

 If Point(\lemx,\lemy+5)<4

   \lemy+2

   If \fall=3

     \lemm+1

     If \lemm<18

       \lemm=18

     Else

       If \lemm>21Then \lemm=18

     EndIf

   Else

     \fall+1

   EndIf

 Else

   \fall=0

   Select \dir

     Case1

       \lemm+1:If \lemm>8Then \lemm=0

       If Point(\lemx+2,\lemy)>3           ;boing! hit wall

         If Point(\lemx+2,\lemy-1)=0

          \lemy-2

          If Point(\lemx+2,\lemy)>0

            \lemy-2

          EndIf

         Else

          \dir=2:\lemx-2

          \bcount+1

         EndIf

       Else

        \lemx+1

       EndIf

    Case2

       \lemm-1

       If \lemm<9

          \lemm=17

        Else

          If \lemm>17 Then \lemm=17

        EndIf

       If Point(\lemx-2,\lemy)>3           ;boing! hit wall

         If Point(\lemx-2,\lemy-1)=0

          \lemy-2

          If Point(\lemx+2,\lemy)>0

            \lemy-2

          EndIf

         Else

           \dir=1:\lemx+2

           \bcount+1

         EndIf       ;boing-handle

       Else

         \lemx-1

       EndIf

    Default

       Gosub randomlem

   End Select

 EndIf

 BBlit db,\lemm,\lemx,\lemy

 If \bcount>4 Then Gosub bc_handle

 If \lemy>200OR \lemx>310OR \lemx<10Then Gosub randomlem; KillItem l()

Wend

Until Joyb(0)>0

End

bc_handle:

 \bcount=0

 Gosub randomlem

Return

randomlem:

 \lemm=0

 \lemx=Rnd(300)+10

 \lemy=5

 rd.b=1-rd

 \dir=rd+1

Return

OldLemmsTest.lha.zip (Größe: 27,81 KB / Downloads: 1816)

Displayscroll (EAB)

Tue, 06 Aug 2019 12:37:01 +0200

Ich hatte mal (damals) ein modifiziertes Beispiel für Displayscroll auf EAB gepostet:
http://eab.abime.net/showpost.php?p=1086590&postcount=7

Das läuft auch super, zumindest mit 50MHz 030er.

Kürzlich jedoch scheint es wieder Diskussionen zu geben, man findet es zu langsam.

Da im o.g. Thread niemand auf das offensichtliche Optimierungspotenzial kommt, schreib ich es hier mal rein (ich bin dort rausgeekelt worden):

Die Leute wollen halt nicht mehr selbst denken.....

Org. Src:

;display scroll adapted by cylon

DEFTYPE.w
BitMap1,320,256,3

LoadBitMap1,"face8.iff",1 ;3planes 8 cols

VWait50
BLITZ

BitMapOutput1 ;print onto bmap

Locate 2,28: Print "THIS IS AGA DISPLAYSCROLL"
Locate 2,30: Print "<<<<< Move Mouse >>>>>"
Use BitMap1

;For a=7To1 Step -1
; b=1-b
; Circlef160,128,10*a,10*a,b
;Next

InitCopList1,44,256,$10003,8,8,-$10

CreateDisplay1

DisplayBitMap1,1

DisplayPalette1,1

For y=0 To7 ;debug colour boxes

Boxf 0,y*16,7,y*16+15,y

Locate2,y*2+0.5:Colour1: Print y

Next y

Dim xpo.q(256),xpe.q(256)

a=0
VWait150
Mouse On

tpi.q=2*Pi ;precalc

xpe(0)=-13 ;offset for even planes start at ypos=0
;not quite accurate! sub-pixel fetch or what the hell....

While Joyb(0)=0

For a=1 To 253
d.q+Pi/18:If d>tpi Then d=0.0

c.q=Sin(d)+(MouseX-160)/160

xpo(a)=c

xpe(a)=c ;same as odd, but with offset

Next
VWait

DisplayScroll1,&xpo(0),&xpe(0);,-13 offset does not work here?

VWait
Wend

VWait25
QAMIGA
End

NoCli:CloseEd
In Fett habe ich mal die dicksten Brummer markiert:
wenn man dort ansetzt (precalc, Tabelle), dann läuft es auch auf dem Standard A1200 mit etwas FastRAM schnell!

Und hier noch die letzte Version.

Da ist der SIN() noch nicht rausoptimiert als Tabelle/Array, aber es reicht auch so....
(getestet auf der realen Maschine, nicht UAE)

Das Pic ist mit drin, ein Exe, und auch der orig. Src vom BUM.

Verdammt, ich kann kein LHA anhängen!

Displayscr_bb.lha.zip (Größe: 24,5 KB / Downloads: 1796)

Schaltjahr (leap year) Func

Sun, 03 Feb 2019 00:24:17 +0100

Der Sinn ist, man nimmt das übliche
date$(ndays)

und findet mit Months heraus, ob man Februar hat. Wenn man dann die Anzahl der Tage feststellen will,
gibt man + leapyear {year} ein, was einen Tag hinzufügt (oder eben nicht) für Februar.

Code:
Function.b leapyear{year.w}  ;returns 1 for leap year or 0

res.b=0

;divisible /100: not a leap year

dummy.w=(year/100)

If (dummy*100)=year

  res=0

  ;divisible /400: leap year

  dummy.w=(year/400)

  If (dummy*400)=year Then res=1

  Function Return res

EndIf

;divisible /4  : leap year

dummy.w=(year/4)  :If (dummy*4)=year Then res=1 Else res=0

Function Return res

End Function

;testcase

NPrint "leap year test case:"

NPrint "1800 (no) ",leapyear{1800}

NPrint "1900 (no) ",leapyear{1900}

NPrint "2100 (no) ",leapyear{2100}

NPrint "2009 (no) ",leapyear{2009}

NPrint "2010 (no) ",leapyear{2010}

NPrint "2011 (no) ",leapyear{2011}

NPrint "2008 (ya) ",leapyear{2008}

NPrint "2012 (ya) ",leapyear{2012}

NPrint "2016 (ya) ",leapyear{2016}

NPrint "2000 (ya) ",leapyear{2000}

NPrint "2400 (ya) ",leapyear{2400}

Stop

RGB - Effekte mit BitplanesBitmap

Sat, 31 Jan 2015 22:39:39 +0100

Habe bei EAB Fragen darüber gesehen, alte Threads. Ich dachte, das gehört aber besser hier her.

RGB-Demo-Effekte, wie z.B. Cubos usw.
Ich hatte so etwas früher schon mal gemacht, beinahe 2 Decaden ist das jetzt her. :o

Also, hier ist ein Beispiel:

meine P96screen.include läuft nicht mit debugger...

Mon, 03 Feb 2014 21:19:02 +0100

hallo, hier nochmal meine bisherige, unzuverlässige Vorgehensweise, wenn ich einen RTG-Screen öffnen will. Unzuverlässig deshalb, weil das Programm offenbar bei Closescreen einfriert; allerdings nur manchmal und nur mit Debugger On.

Code:
; picasso 96 8 bit display, prepared for truecolor

; by Frank Brandis

; CHG: 25.05.2010

; CHG: 06.06.2010   ;alsreq -> fallback. new dispload/save from env:

; Function.l p96_openscreen   {num.w,w.l,h.l,d.l,m.l,t$} ;returns *scr.Screen (.l)

; Function.l p96_askforscreen {num.w,stit$,w.l,h.l,d.l}  ;ask for and opens screen, ret *scr.Screen

; Statement  dispsave {destdir$,w.l,h.l,d.l,m.l}         ;saves DisplayModeID to e.g. Env:

; Function.l dispload {srcdir$ ,w.l,h.l,d.l}             ;loads and returns DisplayID, if exists

INCDIR "blitzinc:src/"

XINCLUDE"screeninfo.ntype.bb"

XINCLUDE"screen_tags.bb"

bb2_p96display$="ENVARC:BlitzP96Modes/" ;directory for storing used GFXCard Modes to use

#p96_loadsave=1     ;set to 0 later

CNIF #p96_loadsave=1

;save given parameters of displaymode to a file usually in ENVARC:

Statement dispsave {dest$,w.l,h.l,d.l,m.l}

  Format""

  newn$=dest$+Str$(w)+"x"+Str$(h)+"x"+Str$(d)   ;"ENV:800x600x8"

  o$="$"+Hex$(m.l)                              ;$50041000

  If NOT(Exists(newn$))

    If WriteFile(1,newn$)

      FileOutput1

        NPrint o$

      CloseFile1:DefaultOutput

    EndIf

  EndIf

End Statement

Function.l dispload {src$,w.l,h.l,d.l}

  Format""

  newn$=src$+Str$(w)+"x"+Str$(h)+"x"+Str$(d)   ;"ENV:800x600x8"

  o$=""                              ;$50041000

  If ReadFile(1,newn$)

    FileInput1

      o$=Inkey$(20)

    CloseFile1:DefaultInput

  EndIf

  Function Return Val(o$)

End Function

CEND

Function.l p96_openscreen {num.w,w.l,h.l,d.l,m.l,t$}

 ScreenTags num.w,t$,#Width,w,#Height,h,#Dpth,d,#AutoScroll,1,#DPen,1,#BPen,2,#DisplayID,m,#LikeWorkbench,1

; ScreenTags num.w,t$,#Width,w,#Height,h,#Dpth,d,#AutoScroll,1,#DisplayID,m

 ;Screen num,0,0,w,h,d,m,t$,1,2

 Function Return Peek.l(Addr Screen(num))

End Function

Function.l p96_askforscreen {num.w,stit$,w.l,h.l,d.l}

 SHARED bb2_p96display$

 FindScreen0    ;get a screen to open asl req on

 scrimem.l=AllocVec_ (SizeOf.screeninfo,#MEMF_PUBLIC|#MEMF_CLEAR)

 If scrimem>0

   *scri.screeninfo=scrimem

 ;  *scri\width  =800 :  *scri\height =600

 ;  *scri\dpth   =8   :  *scri\id     =$50041000

 ;   dispsave {bb2_p96display$,800,600,8,$50041000}

 ;  *scri\width  =640 :  *scri\height =480

 ;  *scri\dpth   =8   :  *scri\id     =$50031000

 ;   dispsave {bb2_p96display$,640,480,8,$50031000}

   *scri\width  =w.l

   *scri\height =h.l

   *scri\dpth   =d.l

   CNIF#p96_loadsave=1

   res.l = dispload {bb2_p96display$,*scri\width,*scri\height,*scri\dpth}

   *scri\id     =res

   CEND

   If *scri\id=0

     *scri=ASLScreenRequest(1|2|4)   ;uncomment this to chg new mode (snoop id with scout)

   EndIf

 Else

   End  ;cancel

 EndIf

 res.l=p96_openscreen {num.w,*scri\width,*scri\height,*scri\dpth,*scri\id,stit$}

 If res

   CNIF#p96_loadsave=1

    dispsave {bb2_p96display$,*scri\width,*scri\height,*scri\dpth,*scri\id}

   CEND

   ;*sc.Screen=res

   ;Gosub main

   Use Screen num

 EndIf

 *scri=0

 FreeVec_ scrimem.l

 Function Return res

End Function

;

;test.l= p96_askforscreen{1,"testscreen",800,600,8}

;If test

;  Delay_150

;  CloseScreen 1

;EndIf

;NPrint Hex$(test)

;MouseWait

;End

das folgende wird bei Verwendung der load/save Option in Envarc: gespeichert:

Code:
envarc:blitzp96modes

   800x600x4

   720x576x24

   800x600x5

   896x600x8

   896x600x24

   800x600x24

   640x480x24

   1152x768x8

   1152x768x24

   1280x854x8

   1280x854x24

   1024x768x8

   1024x768x24

   800x600x8

   720x480x8

   720x480x24

   640x480x8

wer sieht was Illegales/falsches? Wie gesagt, es funktioniert eigentlich. Ich wüßte nur gerne, warum es manchmal eben nicht funktioniert. Ich glaube ja, mein ASL-Screenrequest wird manchmal getrasht, weil ich zum Teil Einträge wie dieses hier finde:

22230303x4202020x2048 oder so. Da ging dann irgendwas schief?

Area-Commands (graphicslib) OLD!

Sat, 01 Feb 2014 13:51:59 +0100

Hallo Leute,

hier mal eine alte Lib für BB2 von mir. Wenn ich mich recht erinnere, funktionierte die recht gut, evtl. gab es auch mal Speicherlecks (Chipmem) oder so, kann mich nicht mehr erinnern.
Wäre schön, wenn da mal jemand drüber schauen könnte.

Code:
;

; RayAreaGfxLib

; programmed for BlitzBasic 2 by Frank Brandis

; (c)opyright 1995 by Frank Brandis

;

; maximum of areasteps = 360 !!!!

;

#rayarealib=22

; graphics

#_allocraster=-492 ;d0=(d0,d1)

#_freeraster =-498 ;   (a0,d0,d1)

#_inittmpras =-468 ;   (a0,a1,d0)

#_initarea   =-282 ;   (a0,a1,d0)

#_areamove   =-252 ;d0=(a1,d0,d1)

#_areadraw   =-258 ;d0=(a1,d0,d1)

#_areaend    =-264 ;   (a1)

#_areaellipse=-186 ;d0=(a1,d0,d1,d2,d3) ;only os3 ????? i dunno ..

#_drawellipse=-180 ;   (a1,d0,d1,d2,d3)

#_setapen    =-342 ;   (a1,d0)

; exec

#_allocmem   =-198 ;d0=(d0,d1)

#_freemem    =-210 ;   (a1,d0)

!libheader {#rayarealib,0,0,0,0}

!astatement

!args {#word,#word,#word}

!libs {#graphicslib,#la6}

!subs {_areastart,0,0}

!name {"Area","x,y,col        ;start of filled polygon"}

!astatement

!args {#word,#word}

!libs {#graphicslib,#la6}

!subs {_areastep,0,0}

!name {"AreaStep","x,y    ;next coord of filled polygon"}

!astatement

!args

!libs {#graphicslib,#la6}

!subs {_areafill,0,0}

!name {"AreaFill","       ;closing the polygon"}

!astatement

!args {#word,#word,#word,#word,#word}

!libs {#graphicslib,#la6}

!subs {_areacirc,0,0}

!name {"WCirclef","x,y,xrad,yrad,col"} ;doesn`t work (areaellipse_)

!astatement

!args {#long,#word,#word,#word,#word}

!libs

!subs {_setptrn,0,0}

!name {"Pattern","*rp,areaptrn1,areaptrn2,areaptrn3,areaptrn4"}

!afunction {#long}

!args {#long,#long,#long,#word}

!libs {#graphicslib,#la0,#execlib,#la1}

!subs {_areainit,0,0}

!name {"AreaInit","(*rp,width,height,maxcoords)  TRUE if success"}

!afunction {#long}

!args

!libs {#execlib,#la6}

!subs {_areafinit,0,0}

!name {"AreaFinit","  BOOLEAN TRUE if success"}

!astatement

!args {#long,#word}

!libs

!subs {_linepat,0,0}

!name {"LinePattern","*rp,pattval    ;pattval could be %1100110011001100"}

!astatement

!args {#long,#long,#byte}

!libs

!subs {_setptrna,0,0}

!name {"PatternA","*rp,&patdef,patsize; user pattern def, patsize must be one of x^2 !!"}

!astatement

!args {#long,#byte}

!libs

!subs {_setolpen,0,0}

!name {"OutlinePen","*rp,colour  ;"}

!astatement

!args {#long,#byte}

!libs

!subs {_oline,0,0}

!name {"Outline","*rp,bool.b     ;   0 or 1,switches areaborders off or on"}

.

!libfin

._areastart

 LEA  rastprt(pc),a0

 MOVE.l      (a0),a1   ;rp here  :)

 MOVEM.l    d0/d1,-(a7);x coord retten

 MOVE.l        d2,d0   ;colour nach d0

 JSR    _setapen(a6)

 MOVEM.l    (a7)+,d0/d1   ;x coord rest.

 JSR   _areamove(a6)   ;AreaMove_ *rp,x,y

RTS

._areastep

 LEA  rastprt(pc),a0

 MOVE.l      (a0),a1

 JSR   _areadraw(a6)   ;AreaDraw_ *rp,x,y

RTS

._areacirc

 LEA  rastprt(pc),a0

 MOVE.l      (a0),a1   ;*rp in a1

 MOVEM.l    d0-d3,-(a7);x coord wegen lvosetapen_ retten

 MOVE.l        d4,d0   ;color nach d0

 JSR     _setapen(a6)

 MOVEM.l    (a7)+,d0-d3;x coord rest.

; JSR _areaellipse(a6) ;AreaEllipse_ *rp,x,y,rx,ry  ,col

 JSR _drawellipse(a6)

 JSR     _areaend(a6)  ;AreaEnd_ *rp

RTS

RTS

._areafill

 LEA  rastprt(pc),a0

 MOVE.l      (a0),a1

 JSR    _areaend(a6)   ;AreaEnd_ *rp

RTS

.

._areainit

 LEA      gfxbas(pc),a2

 MOVE.l           a0,(a2)

 LEA     execbas(pc),a2

 MOVE.l           a1,(a2)

 LEA     rastprt(pc),a1         ;rastport sichern

 MOVE.l           d0,(a1)

 MOVE.l           d3,d0         ;max. areasteps

 ADD.l            #1,d0         ;ein schritt zu maxsteps hinzu

 MULU             #5,d0         ;mal 5,wegen rasteralloc.

 LEA      msteps(pc),a0

 MOVE.l           d0,(a0)       ;als maxsteps sichern

 LEA        widt(pc),a1

 MOVE.w           d1,(a1)

 MOVE.w           d1,d0         ;width, should be windows max width

 LEA        heit(pc),a1

 MOVE.l           d2,(a1)

 MOVE.l           d2,d1         ;height, should be windows max height

 LEA      gfxbas(pc),a1

 MOVE.l         (a1),a6

 JSR   _allocraster(a6)

 LEA         ras(pc),a1

 MOVE.l           d0,(a1)       ;ras.l=AllocRaster_(640,256)

 CMP.l #0,d0:BEQ noinit

 LEA        widt(pc),a0        ;

 MOVE.l         (a0),d0        ;

 DIVU             #8,d0        ;

 LEA        heit(pc),a0        ;

 MOVE.l         (a0),d1        ;

 MULU             d1,d0        ; MOVE.l #$14000,d0   ;(640/8)*256)

 LEA         ras(pc),a0

 MOVE.l         (a0),a1

 LEA      tmpras(pc),a0

 JSR    _inittmpras(a6)   ;err.l=InitTmpRas_(tmpras,buf.l,(640/8)*256)

 LEA     execbas(pc),a0

 MOVE.l         (a0),a6

 LEA      msteps(pc),a1

 MOVE.l         (a1),d0

 MOVE.l      #$10001,d1

 JSR      _allocmem(a6)

 LEA        buff(pc),a0

 MOVE.l           d0,(a0)     ;buff$=String$(" ",(msteps+1)*5)

 CMP.l #0,d0:BEQ  noinit

 LEA      gfxbas(pc),a0

 MOVE.l         (a0),a6

 LEA        buff(pc),a0

 MOVE.l         (a0),a1

 LEA     areainf(pc),a0  ;eigene structur

 MOVE.l         #360,d0

 JSR      _initarea(a6)  ;err.l=InitArea_(*ai.AreaInfo,&buff$,360)

 LEA     rastprt(pc),a0

 MOVE.l         (a0),a1

 LEA      tmpras(pc),a0

 MOVE.l           a0,SizeOf.RastPort\TmpRas(a1)     ;*rp\TmpRas=tmpras

 LEA     areainf(pc),a0

 MOVE.l           a0,SizeOf.RastPort\AreaInfo(a1)   ;*rp\AreaInfo=*ai

 MOVEQ            #1,d0

 BRA okinit

 noinit:

 MOVEQ           #0,d0

 okinit:

RTS

._areafinit

 LEA        widt(pc),a0   ;

 MOVE.l         (a0),d0   ;MOVE.w         #640,d0

 LEA        heit(pc),a0   ;

 MOVE.l         (a0),d1   ;MOVE.w         #256,d1

 LEA      gfxbas(pc),a0

 MOVE.l         (a0),a6

 LEA         ras(pc),a1

 MOVE.l         (a1),a0

 JSR    _freeraster(a6)   ;FreeRaster_ *ras,640,256

 LEA     execbas(pc),a0

 MOVE.l         (a0),a6

 LEA      msteps(pc),a0   ;

 MOVE.l         (a0),d0

 LEA        buff(pc),a0   ;

 MOVE.l         (a0),a1

 JSR       _freemem(a6)

 ; d0=result

RTS

.

._setptrn

MOVE.l       d0,a1

LEA   patt1(pc),a0

MOVE.w       d1,(a0)+

MOVE.w       d2,(a0)+

MOVE.w       d3,(a0)+

MOVE.w       d4,(a0)

LEA   patt1(pc),a0

MOVE.l       a0,SizeOf.RastPort\AreaPtrn(a1)

MOVE.b       #2,SizeOf.RastPort\AreaPtSz(a1) ;heavy error last version

RTS

._setptrna

MOVE.l       d0,a1    ;rastprt

MOVE.l       d1,SizeOf.RastPort\AreaPtrn(a1)

MOVE.b       d2,SizeOf.RastPort\AreaPtSz(a1)

RTS

._linepat

 MOVE.l d0,a1

 MOVE.w d1,SizeOf.RastPort\LinePtrn(a1)

RTS

._setolpen

 MOVE.l d0,a1

 MOVE.b d1,SizeOf.RastPort\AOlPen(a1)

; MOVE.w SizeOf.RastPort\Flags(a1),d0

; BSET   #3,d0

; MOVE.w d0,SizeOf.RastPort\Flags(a1)

RTS

._oline

 MOVE.l  d0,a1

 SUB.l   d0,d0

 MOVE.w SizeOf.RastPort\Flags(a1),d0

 CMP.b   #0,d1

 BEQ dof

 BSET    #3,d0

 bck:MOVE.w d0,SizeOf.RastPort\Flags(a1)

RTS

dof:BCLR #3,d0:BRA bck

tmpras:  ;struct

 Dc.l 0

 Dc.l 0

areainf:Dcb.l 8,0

execbas:Dc.l 0

gfxbas: Dc.l 0

rastprt:Dc.l 0

ras:    Dc.l 0

msteps: Dc.l 0

buff:   Dc.l 0

widt:   Dc.w 0

heit:   Dc.w 0

patt1:  Dc.w 0,0,0,0

Even