+- AmiBlitz³ (https://www.amiblitz.de/community)
+-- Forum: Blitzbasic2 (https://www.amiblitz.de/community/forum-5.html)
+--- Forum: Snippets & Libraries (https://www.amiblitz.de/community/forum-11.html)
+--- Thema: bPaint (AMOS Recreation) mit Src (/thread-208.html)
bPaint (AMOS Recreation) mit Src - hackball - 06.09.2020
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!
[attachment=35]
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<oldx Then Exchange wx,oldx
If wy<oldy Then Exchange wy,oldy
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