Inspired by http://www.purebasic.fr/english/viewtopic.php?t=32421
Only this is fully rewritten from scratch to support automatic text wrapping of lines, supports any image/gadget/window size. Background and Foreground color, background image, individual line colors. Auto repeating. System friendly graphic updating (no CPU hogging), scales background to match scroll image/gadget. Also showcases a custom thread "killing" method.
There is lots of room for improvement though so if anyone feel up to it, go for it. Hopefully there are no bugs.
More text features could be added, like left/center/right line alignment. And maybe optimize and simplify the code even further.
Hope somebody find this usefull
The following code is Public Domain.
Code: Select all
EnableExplicit
Structure _CreateEasyThread_Structure
thread.l
terminate.l
*param
EndStructure
;EasyThread is a friendly way to handle threads.
;The purpose is to avoid killing a thread, instead you terminate a thread by signaling it.
;You need to add the signal check in you thread loop yourself by checking
;if *thread\terminate is #True.
;Threads that have no loops and take a short time need to terminate checks,
;but threads that have long loops or tasks that take a long time
;should check the *thread\terminate variable.
;EasyThread also let you optionally set the priority when you create the thread.
;Thanks to the EasyThread allocated structure being passed as the threads parameter
;a thread can easily reference itself if you should ever need to do that.
Procedure.l EasyCreateThread(*proc,*param,priority.l=#Null)
Protected result.l=#False,*thread._CreateEasyThread_Structure
*thread=AllocateMemory(SizeOf(_CreateEasyThread_Structure))
If *thread
*thread\terminate=#False
*thread\param=*param
*thread\thread=CreateThread(*proc,*thread)
If priority
Repeat
Delay(1)
Until IsThread(*thread\thread)
ThreadPriority(*thread\thread,priority)
EndIf
result=#True
EndIf
If result=#False
If *thread
FreeMemory(*thread)
EndIf
*thread=#Null
EndIf
ProcedureReturn *thread
EndProcedure ;Returns the EasyThread handle/pointer
;EasyThreads with loops must check if *thread\terminate is true and gracefully quit.
;This is different from how normal PB threads are.
;It is not good coding to have to kill a thread, so EasyThread let you singal the thread
;and tell it to quit by setting *thread\terminate to true.
;A timeout value is also supported, if waiting reaches the timeout then this procedure
;will return, see EndProcedure below for return values.
Procedure.l EasyTerminateThread(*thread._CreateEasyThread_Structure,timeout.l=#Null)
If *thread
If IsThread(*thread\thread)
*thread\terminate=#True
If timeout<0
timeout=1
EndIf
If timeout>#Null
WaitThread(*thread\thread,timeout)
Else
WaitThread(*thread\thread)
EndIf
EndIf
If Not IsThread(*thread\thread)
FreeMemory(*thread)
*thread=#Null
EndIf
EndIf
ProcedureReturn *thread
EndProcedure ;If #Null the thread terminated, if not #Null it is still running.
;If you really need to force (kill) a EasyThread then use the above procedure first,
;if the thread did not terminate then you can try KillThread(easythread)
;But remember to use EasyTerminateThread() afterwards to free the EasyThread memory.
Procedure.l EasyIsThread(*thread._CreateEasyThread_Structure)
If *thread
If Not IsThread(*thread\thread)
*thread=#Null
EndIf
EndIf
ProcedureReturn *thread
EndProcedure ;Behaves similar to IsThread()
Procedure.l EasyThreadPrioity(*thread._CreateEasyThread_Structure,priority.l)
If *thread
If IsThread(*thread\thread)
priority=ThreadPriority(*thread\thread,priority)
EndIf
EndIf
ProcedureReturn priority
EndProcedure ;Behaves similar to ThreadPriority()
Procedure.l EasyPauseThread(*thread._CreateEasyThread_Structure,timeout.l=#Null)
PauseThread(*thread\thread)
ProcedureReturn *thread
EndProcedure ;Behaves similar to PauseThread()
Procedure.l EasyResumeThread(*thread._CreateEasyThread_Structure)
ResumeThread(*thread\thread)
ProcedureReturn *thread
EndProcedure ;Behaves similar to ResumeThread()
Procedure.l EasyThreadID(*thread._CreateEasyThread_Structure)
Protected threadid.l=#Null
If *thread
If IsThread(*thread\thread)
threadid=ThreadID(*thread\thread)
EndIf
EndIf
ProcedureReturn threadid
EndProcedure ;Behaves similar to ThreadID()
Structure _Scroll_Credits_Struct
gadget.l
image.l
imageid.l
width.l
height.l
textheight.l
pos.l
bgimage.l
bgimageid.l
loop.l
fontid.l
bgcolor.l
fgcolor.l
EndStructure
Structure _Scroll_Credits_Text_Struct
text$
color.l
EndStructure
Global NewList Scroll_Credits_Text_List._Scroll_Credits_Text_Struct()
Global Scroll_Credits_Info._Scroll_Credits_Struct
Procedure.l Scroll_Credits_Init(text_list._Scroll_Credits_Text_Struct(),image_gadget.l,loop.l=0,fgcolor.l=#White,bgcolor.l=#Black,font.l=#PB_Default,background_image.l=#PB_Any)
Protected result=#False
Protected output.l,textheight.l,textwidth.l,i.l,pos.l
Protected limit.l,cut.l,width.l,text$
Scroll_Credits_Info\gadget=#PB_Any
Scroll_Credits_Info\bgimage=#PB_Any
If loop=0 : loop=-1 : EndIf
Scroll_Credits_Info\loop=loop
Scroll_Credits_Info\fgcolor=fgcolor
Scroll_Credits_Info\bgcolor=bgcolor
If IsGadget(image_gadget) And (CountList(text_list())>0)
Scroll_Credits_Info\gadget=image_gadget
Scroll_Credits_Info\width=GadgetWidth(image_gadget)
Scroll_Credits_Info\height=GadgetHeight(image_gadget)
Scroll_Credits_Info\pos=Scroll_Credits_Info\height-1
If IsFont(font)
Scroll_Credits_Info\fontid=FontID(font)
Else
If #PB_Compiler_OS=#PB_OS_Windows
Scroll_Credits_Info\fontid=GetStockObject_(#DEFAULT_GUI_FONT)
Else
Scroll_Credits_Info\fontid=#PB_Default
EndIf
EndIf
If IsImage(Scroll_Credits_Info\image)
CreateImage(Scroll_Credits_Info\image,Scroll_Credits_Info\width,Scroll_Credits_Info\height,#PB_Image_DisplayFormat)
Else
Scroll_Credits_Info\image=CreateImage(#PB_Any,Scroll_Credits_Info\width,Scroll_Credits_Info\height,#PB_Image_DisplayFormat)
EndIf
If IsImage(Scroll_Credits_Info\image)
Scroll_Credits_Info\imageid=ImageID(Scroll_Credits_Info\image)
If background_image<>#PB_Any
If IsImage(background_image)
Scroll_Credits_Info\bgimage=CopyImage(background_image,#PB_Any)
If IsImage(Scroll_Credits_Info\bgimage)
ResizeImage(Scroll_Credits_Info\bgimage,Scroll_Credits_Info\width,Scroll_Credits_Info\height)
If IsImage(Scroll_Credits_Info\bgimage)
Scroll_Credits_Info\bgimageid=ImageID(Scroll_Credits_Info\bgimage)
result=#True
EndIf
EndIf
EndIf
Else
result=#True
EndIf
EndIf
EndIf
If result
output=ImageOutput(Scroll_Credits_Info\image)
If output
If StartDrawing(output)
DrawingFont(Scroll_Credits_Info\fontid)
ResetList(text_list())
SelectElement(text_list(),0)
textheight=TextHeight(text_list()\text$)+3
pos=0
width=(Scroll_Credits_Info\width-21)
ClearList(Scroll_Credits_Text_List())
ForEach text_list()
text$=text_list()\text$
Scroll_Credits_Info\fgcolor
If text_List()\color<>0
If text_List()\color=-1
fgcolor=Scroll_Credits_Info\fgcolor
Else
fgcolor=text_List()\color
EndIf
EndIf
textwidth=TextWidth(text$)
If textwidth>width
While textwidth>width
limit=0
Repeat
limit+1
Until TextWidth(Left(text$,limit))>width
cut=limit
Repeat
cut-1
Until Mid(text$,cut,1)=" " Or cut=0
If cut=0
cut=limit-1
EndIf
AddElement(Scroll_Credits_Text_List())
Scroll_Credits_Text_List()\text$=Left(text$,cut)
Scroll_Credits_Text_List()\color=fgcolor
text$=Right(text$,Len(text$)-cut)
textwidth=TextWidth(text$)
pos+textheight
Wend
text$=Left(text$,cut)
EndIf
AddElement(Scroll_Credits_Text_List())
Scroll_Credits_Text_List()\text$=text$
Scroll_Credits_Text_List()\color=fgcolor
pos+textheight
Next
Scroll_Credits_Info\textheight=textheight
StopDrawing()
EndIf
EndIf
Else
ClearList(Scroll_Credits_Text_List())
If IsImage(Scroll_Credits_Info\image)
FreeImage(Scroll_Credits_Info\image)
EndIf
Scroll_Credits_Info\image=#PB_Any
EndIf
ProcedureReturn result
EndProcedure
Procedure.l Scroll_Credits_Free()
ClearList(Scroll_Credits_Text_List())
If IsImage(Scroll_Credits_Info\image)
FreeImage(Scroll_Credits_Info\image)
EndIf
Scroll_Credits_Info\image=#PB_Any
ProcedureReturn #True
EndProcedure
Procedure.l Scroll_Credits_ChangeBackground(background_image.l=#PB_Any)
If IsImage(background_image)
Scroll_Credits_Info\bgimage=CopyImage(background_image,#PB_Any)
If IsImage(Scroll_Credits_Info\bgimage)
ResizeImage(Scroll_Credits_Info\bgimage,Scroll_Credits_Info\width,Scroll_Credits_Info\height)
If IsImage(Scroll_Credits_Info\bgimage)
Scroll_Credits_Info\bgimageid=ImageID(Scroll_Credits_Info\bgimage)
EndIf
EndIf
Else
Scroll_Credits_Info\bgimage=#PB_Any
EndIf
ProcedureReturn (Scroll_Credits_Info\bgimage<>#PB_Any)
EndProcedure
Procedure.l Scroll_Credits(*thread._CreateEasyThread_Structure)
Protected result.l=#False,output.l,textheight.l,textwidth.l,pos.l
Protected ms.l,period.l
ms=timeGetTime_()
period=ms-100
Repeat
ms=timeGetTime_()
If (ms-period)>=100
period=ms
If Scroll_Credits_Info\image<>#PB_Any
output=ImageOutput(Scroll_Credits_Info\image)
If output
If StartDrawing(output)
FrontColor(Scroll_Credits_Info\fgcolor)
BackColor(Scroll_Credits_Info\bgcolor)
If Scroll_Credits_Info\bgimage<>#PB_Any
DrawImage(Scroll_Credits_Info\bgimageid,0,0)
Else
Box(0,0,Scroll_Credits_Info\width,Scroll_Credits_Info\height,Scroll_Credits_Info\bgcolor)
EndIf
DrawingMode(#PB_2DDrawing_Transparent)
DrawingFont(Scroll_Credits_Info\fontid)
textheight=Scroll_Credits_Info\textheight+3
pos=Scroll_Credits_Info\pos
ForEach Scroll_Credits_Text_List()
If (pos>-textheight) And (pos<Scroll_Credits_Info\height)
DrawText(10,pos,Scroll_Credits_Text_List()\text$,Scroll_Credits_Text_List()\color)
EndIf
pos+textheight
Delay(0)
Next
Scroll_Credits_Info\pos-1
If pos<0
Scroll_Credits_Info\pos=Scroll_Credits_Info\height-1
If Scroll_Credits_Info\loop<>-1
Scroll_Credits_Info\loop-1
If Scroll_Credits_Info\loop<0
Scroll_Credits_Info\loop=0
EndIf
EndIf
EndIf
StopDrawing()
SetGadgetState(Scroll_Credits_Info\gadget,Scroll_Credits_Info\imageid)
EndIf
EndIf
EndIf
Else
Delay(1)
EndIf
Until (*thread\terminate) Or (Scroll_Credits_Info\loop=0)
Scroll_Credits_Info\loop=0
If *thread\terminate=#False
EasyTerminateThread(*thread,1)
EndIf
ProcedureReturn result
EndProcedure
;Test program
If #PB_Compiler_OS=#PB_OS_Windows
timeBeginPeriod_(1)
EndIf
Define thread.l
OpenWindow(0,0,0,600,600,"PureBasic 4.20 Beta News",#PB_Window_SystemMenu|#PB_Window_ScreenCentered)
CreateImage(1,WindowWidth(0), WindowHeight(0), #PB_Image_DisplayFormat)
CreateGadgetList(WindowID(0))
ImageGadget(0,0,0,WindowWidth(0),WindowHeight(0), ImageID(1))
;Color is any RGB() value except $0 which is considered no color chosen.
;Sorry, to get black you need to use $010101 or similar as lists can't be given a default value.
;If -1 is fiven as color then the drawing routines go back to default color that you specified during the init.
NewList text._Scroll_Credits_Text_Struct()
AddElement(text())
text()\text$="Hi, "
AddElement(text())
text()\text$="Update: 4.20 Beta 6 for Windows is out, 4.20 Beta 2 for Linux and 4.20 Beta 1 for MacOS X as well ! "
AddElement(text())
text()\text$="Here is the fifth beta release of the forthcoming 4.20 version of PureBasic. It's getting longer as expected, and we would like to spend some time to explain why."
AddElement(text())
text()\text$="Don't flip out, it will be probably the last beta, If everything goes nicely. Here is the story: "
AddElement(text())
text()\text$=""
AddElement(text())
text()\text$="At first, 4.20 was meant to be a 'new command only' release. So no big problems were foreseen, as we won't work on the compiler Or debugger. Better, most of the"
AddElement(text())
text()\text$="new libraries were already written, as we often do extra interresting work when fixing bugs is becoming too boring (we don't include the new library in the release"
AddElement(text())
text()\text$="tree, so the library can maturate pacefully). So good so far, 2 months after the 4.10 release, a new beta hit the ground. and now, things got a bit more complex. "
AddElement(text())
text()\text$="We encounter again a LccWin32 bugs/limitation so we decided it was time to migrate to VisualC++ 2005. This choice was made for serveral reasons:"
AddElement(text())
text()\text$=""
AddElement(text())
text()\color=$FF7F00
text()\text$=" 1) It is the 'official' C/C++ compiler on Windows "
AddElement(text())
text()\text$=" 2) It is free (we use the excellent 'Express' edition) "
AddElement(text())
text()\text$=" 3) It produce very good code (much better than lcc - some libs gained 50-100% in speed just by switching the compiler)"
AddElement(text())
text()\text$=" 4) It has a X64 version as well, so we have a direct port to 64 bits Windows without too much hassle (at least for the libraries) "
AddElement(text())
text()\text$=" 5) Bug free (at least on the compiler side) "
AddElement(text())
text()\text$=""
AddElement(text())
text()\color=#PB_Any
text()\text$="So we started so migration of all the libraries and compiler libraries (SystemBase, StringManager, etc..). Some of them used lcc inline ASM, so needed quite some"
AddElement(text())
text()\text$="work to have them to work. VC++ is also more picky and tons of warning appears and needed a correction. Moreover we activated the 64 bits portability check and"
AddElement(text())
text()\text$="our console were definitely flooded. Think than when we migrate the whole commandset, it affect tousand of files, all the makefiles needs to be adapted etc. But"
AddElement(text())
text()\text$="as you can understand, it is for the best. Several weeks later, we got everything building fine and as you guessed it, the 64 bits compiling was (almost) working"
AddElement(text())
text()\text$="as well. It was the base to begin the work for the famous X64 compiler. "
AddElement(text())
text()\text$=""
AddElement(text())
text()\text$="We though we were done with this, but a strange VC8 optimisation affected the way PureBasic called string functions (PureBasic assumed than the arguments passed"
AddElement(text())
text()\text$="on the stack for the functions would never be modified by a C function (and it is the Case with lcc and gcc). But there is no clear infos on this, and VC8 "
AddElement(text())
text()\text$="actually use the stack parameters as temp area If needed). So a compiler modification was needed to fix that, after a lot of investiigation (we got random crashes"
AddElement(text())
text()\text$="on some functions). In between, we faced some regressions so we have written much more unitary tests to make the commandset more robust to changes. These are"
AddElement(text())
text()\text$="running using the 'PureUnit' tool developped by Timo (Fr34k) which will made its way in the official PB package soon, as it's really a great help to ensure a "
AddElement(text())
text()\text$="module behaves as expected, on every plateform. "
AddElement(text())
text()\text$="Now that all the libraries and helpers were compiled with VC8, we couldn't let the compiler itself using Lcc. So we started the migration as well. The gains for the"
AddElement(text())
text()\text$="compile time was good (10-30%) but we needed to trick a bit VC8 to use an old VC runtime dll (MSVCRT.dll) instead of the new VC8 one, as it wouldn't run out of the"
AddElement(text())
text()\text$="box without shipping the VC8 runtimes. Google helped here . "
AddElement(text())
text()\text$=""
AddElement(text())
text()\color=$00BF9F
text()\text$="On another topic, CVS is dying and replaced everywhere by SVN. We migrated the libs repository some time ago, but the compiler and internal tools were still using"
AddElement(text())
text()\text$="this old aged CVS. The migration wasn't very smooth as the CVS repository was on an NT based computer While the script needed to do the migration were on linux."
AddElement(text())
text()\text$="After some twists, it finally worked. So SVN everywhere. And it's way better, honestly. "
AddElement(text())
text()\text$=""
AddElement(text())
text()\color=$009FBF
text()\text$="Timo wanted to add a profiler to the IDE, so he did. And he did well. So it remainded me than i didn't profiled the compiler since a while and it could be quite "
AddElement(text())
text()\text$="fun to do. I tried to find a good profiler on Windows (anyone ?) but only found the costly Quantify (and even, the demo version showed only API call with VC8 "
AddElement(text())
text()\text$="executable, dunno If it's on purpose Or If it's a bug). So i fired it my linux box and used gprof and the linux compiler. I used the IDE source code as benchmark"
AddElement(text())
text()\text$="(60 000 lines). And here, the disaster: 23 millions of stricmp() call - called when looking for a token (like constant, Structure, Procedure, functions, Macro etc.)"
AddElement(text())
text()\text$="Seems like my old lookup tables are suffering here. For sure, the residents have almost 8000 constants and the lookup table was way too small. I decided to change "
AddElement(text())
text()\text$="that with real hash map. The gain was impressive, now only 500 000 calls to stricmp() are done. The whole processing time of the source code fall down from 3500 ms"
AddElement(text())
text()\text$="to 500 ms on my computer. This optimisation is available in the Beta 5, so If you have a big project, you may feel the difference. "
AddElement(text())
text()\text$=""
AddElement(text())
text()\color=$BF009F
text()\text$="We also wanted to tackle most of the important remaining bugs since the last 4.10 version (and even before), so we spend quite some time to fix thus (on the 3 OSes)."
AddElement(text())
text()\text$="This led me to rework the 'QuadUnit', which is used to manipulate and execute quad based operation. The one developped for PB 4.00 was good but way too complex"
AddElement(text())
text()\text$="and some case were really hard to handle. So i simplified the whole design and recoded several key part. This change is also in Beta 5, so don't hesitate to report"
AddElement(text())
text()\text$="bugs If any. At least, all the quad reported bugs are now fixed. It should have no Or very few regression as all fixed bugs are part of the compiler unit tests"
AddElement(text())
text()\text$="(every compiler bugs fixed get a new entry in the regression test suite). "
AddElement(text())
text()\text$=""
AddElement(text())
text()\text$="In fact, we added too much commands for a single version, but hey, we are megalomaniacs. Thus we got plently bugs reports on these (logically as these new"
AddElement(text())
text()\text$="libraries were not trivials). Thanks to all of you for the reports and the patience. "
AddElement(text())
text()\text$=""
AddElement(text())
text()\color=$9F00BF
text()\text$="As we can't stop, when we need to work on some fresh stuffs, we started the 64 bits version of PureBasic and the MacOS X x86 version. One could think than the"
AddElement(text())
text()\text$="MacOS X x86 version would be just a matter a recompiling, but you couldn't be that wrong. OS X x86 ABI is just horrible and need very strick stack alignement"
AddElement(text())
text()\text$="everywhere (on 16 bytes boundaries) which the Windows/Linux version doesn't requiers. If the stack is misaligned, it sometimes work, sometimes not, leading to very"
AddElement(text())
text()\text$="hard to track bugs. So, the compiler has been reworked to handle stack alignment all over the code. Moreover, FASM is not available on OS X x86, so we decided to"
AddElement(text())
text()\text$="migrate all the assembly libraries (linked list, misc etc.) on NASM. Indeed the compiler has been modified to output NASM compatible code instead of FASM."
AddElement(text())
text()\text$="On the x64 side, the work has been even harder as the assembly itself isn't the same. Well, both are coming quite nicely, and the public test will come soon. "
AddElement(text())
text()\text$=""
AddElement(text())
text()\color=$9FBF00
text()\text$="The last but not the least, many new commands means a lot of doc to write. This takes a lot of time, as we do it in 3 languages as you know. The beta 5 comes with"
AddElement(text())
text()\text$="the doc in 3 langages, for all new commands. "
AddElement(text())
text()\text$=""
AddElement(text())
text()\color=#PB_Any
text()\text$="Ok, so you can grab the beta 5 on your account and test it. The beta for Linux and OS X are ready as well, but we will wait a bit before publishing them"
AddElement(text())
text()\text$="(to see If there is no major quirks. And btw, If you were using the beta 4, check your 'Temp' directory as a nasty bug didn't remove all the PB temp dirs and it"
AddElement(text())
text()\text$="could take some space. "
AddElement(text())
text()\text$=""
AddElement(text())
text()\color=$7FEF1F
text()\text$="Have fun ! "
AddElement(text())
text()\text$=""
AddElement(text())
text()\color=$7F7FEF
text()\text$="The Fantaisie Software Team"
AddElement(text())
text()\text$=""
AddElement(text())
text()\text$=""
;This is the real magic part, I'm too lazy to comment it all properly, sorry :)
;Loop is how many times you want it to loop, 0 is forever.
If Scroll_Credits_Init(text(),0,1)
thread=EasyCreateThread(@Scroll_Credits(),#Null)
EndIf
Repeat
Until WaitWindowEvent()=#PB_Event_CloseWindow
EasyTerminateThread(thread)
Scroll_Credits_Free()
If #PB_Compiler_OS=#PB_OS_Windows
timeEndPeriod_(1)
EndIf
End
