Forum - Socoder

-=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- (c) WidthPadding Industries 1987 0\|391\|0 -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=- -=+=-
Socoder -> Blitz -> stream error
Mon, 24 Jan 2011, 11:56
dna	With this code Repeat A_FILE$=NextFile(THE_DIR):;Print CK$+" "+F1+" "+F2+" "+FileType(A_FILE$):Goto HALT If FileType(A_FILE$)<>2 ;Or Right$(A_FILE$,3)<>"SAN" CK$=DI$+"\"+A_FILE$:;Print CK$:Goto HALT F1=ReadFile(CK$):F2=ReadFile("PS.DAT"):Print CK$+" "+F1+" "+F2 While Not Eof(F1) GET.BYTES=New BYTES:GET\A_BYTE=ReadByte(F1):If Eof(F2) Then SeekFile(F2,0) . . wend . . until A_FILE="" --v I get a "stream does not exist" error. -=-=- DNA
Mon, 24 Jan 2011, 12:07
shroom_monk	I haven't tried running the code, but could it be that 'A_FILE' on the last line should be 'A_FILE$'? -=-=- A mushroom a day keeps the doctor away... Keep It Simple, Shroom!
Mon, 24 Jan 2011, 12:30
dna	I think Jay mentioned that once it's defined as a string then the dollar sign may be optional. I'll try it though since that was the syntax method I used mostly during school. Nope. The software does the same even with the dollar sign. When using FILETYPE(...), is the value returned 1,0,-1? I'm getting conflicting documentation. -=-=- DNA
Mon, 24 Jan 2011, 12:32
HoboBen	To be honest it almost impossible to read formatted like that (are the semi-colons Blitz comments?). What is the code actually meant to do? -=-=- blog \| work \| code \| more code
Mon, 24 Jan 2011, 12:46
dna	Here's the edited code for better reading. .READIT THE_DIR=ReadDir(DI$) Repeat A_FILE$=NextFile(THE_DIR) If FileType(A_FILE$)<>2 CK$=DI$+"\"+A_FILE$: F1=ReadFile(CK$):F2=ReadFile("PS.DAT"):Print CK$+" "+F1+" "+F2 While Not Eof(F1) GET.BYTES=New BYTES:GET\A_BYTE=ReadByte(F1):If Eof(F2) Then SeekFile(F2,0) GET\B_BYTE=ReadByte(F2):GET\C_BYTE=GET\A_BYTE + GET\B_BYTE Wend:CloseFile(F1):F1=WriteFile(CK$):For GET.BYTES=Each BYTES:WriteByte(F1,GET\C_BYTE):Next:CloseFile(F1) EndIf Until A_FILE$="" .HALT WaitKey:End --v The code reads from two files adds the contents and then writes the information back to a file. -=-=- DNA
Mon, 24 Jan 2011, 13:59
Teasy	DNA: Seeking back to start on end-of-file should work exactly as you intended: Graphics 800,600 , 0,2 Const ScreenWidth = 640 Const ScreenHeight = 480 Graphics ScreenWidth,ScreenHeight , 0,3 BPL_Init pCls 0,64,128 pColor 192,224,255 pLocate 0,ScreenHeight SetFont LoadFont( "FixedSys" ) SetBuffer BackBuffer() ; open a file for reading Const file$ = "stream test 2011-01-24 1c.bb" Local stream = ReadFile( file ) ; abort with error if not opened succesfully If stream = 0 RuntimeError "Unable to open file:"+Chr(13)+file End If ; display size pPrint String("--",30) pPrint "File: "+file pPrint "Size: "+FileSize( file ) pPrint String("--",30) pPrint ; start at end of file SeekFile stream , FileSize( stream ) Repeat ; when end of file reached If Eof( stream ) ; start at the beginning SeekFile stream , 0 pPrint pPrint pPrint String("&#",30) pPrint String("#&",30) pPrint End If ; read next data/byte from file Local byte = ReadByte( stream ) Select byte Case 9 ; tab pWrite String(" ",4) Case 13 ; enter: carriage return (CR) pPrint Case 10 ; enter: linefeed (LF) Default pWrite Chr(byte) End Select Flip False Delay 15 Until KeyHit( 1 ) ; escape End ;------------------------------------------------------------------------------- Repeat A_FILE$=NextFile(THE_DIR):;Print CK$+" "+F1+" "+F2+" "+FileType(A_FILE$):Goto HALT If FileType(A_FILE$)<>2 ;Or Right$(A_FILE$,3)<>"SAN" CK$=DI$+"\"+A_FILE$:;Print CK$:Goto HALT F1=ReadFile(CK$) F2=ReadFile("PS.DAT") Print CK$+" "+F1+" "+F2 While Not Eof(F1) ; GET.BYTES=New BYTES ; GET\A_BYTE=ReadByte(F1) If Eof(F2) Then SeekFile(F2,0) ;.. Wend ;.. End If Until A_FILE="" ;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: ; Print, Write, Locate, Input replacement for Blitz 3D ; Created by Teasy <TheChange@yahoo.com> ; Special "Include" edition 24 Jan 2011 (Origin: BlitzPrint1c.Lib.BB) ;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: ; ; make every call to Write/Print and/or Input show up on screen instantly ; - suitable for switching between front/backbuffer ; - setting a value of -1 (auto-detect) will flip when drawing to the backbuffer ; - default -1 (for both) Global BPL_PrintFlips = -1 Global BPL_InputFlips = -1 ; ; use vertical sync on any flip (default off) Global BPL_FlipVSync = False ; ; add a delay after a flip (default on) ; - recommended delay time: 1..10 ms (default 1 ms) Global BPL_FlipDelay = True Global BPL_FlipDelayTime = 1 ; ; defaults (should be synced with blitz's default) Const BPL_Default_x = 0 Const BPL_Default_y = 0 Const BPL_Default_br = 0 Const BPL_Default_bg = 0 Const BPL_Default_bb = 0 Const BPL_Default_r = 255 Const BPL_Default_g = 255 Const BPL_Default_b = 255 ; Type BPL_PrintTYPE Field x,y Field br,bg,bb Field r,g,b Field key,keystart,keyrepeat End Type ; Global BPL_Print_.BPL_PrintTYPE ; Function BPL_Init() BPL_Print_ = New BPL_PrintTYPE pLocate BPL_Default_x,BPL_Default_y pClsColor BPL_Default_br,BPL_Default_bg,BPL_Default_bb , False pColor BPL_Default_r,BPL_Default_g,BPL_Default_b , False End Function ; Function pClsColor( r=0,g=0,b=0 , native=True ) BPL_Print_\br = r BPL_Print_\bg = g BPL_Print_\bb = b If native Then ClsColor r,g,b End Function ; Function pCls( r=-1,g=-1,b=-1 , native=True ) If native If b<>-1 pClsColor r,g,b End If Cls Else If b=-1 Color BPL_Print_\br,BPL_Print_\bg,BPL_Print_\bb Else Color r,g,b End If Rect 0,0 , GraphicsWidth(),GraphicsHeight() Color BPL_Print_\r,BPL_Print_\g,BPL_Print_\b End If End Function ; Function pColor( r=0,g=0,b=0 , native=True ) BPL_Print_\r = r BPL_Print_\g = g BPL_Print_\b = b If native Then Color r,g,b End Function ; Function pLocate( x,y ) BPL_Print_\x = x BPL_Print_\y = y End Function ; Function pPrint( msg$="" , cr=True , limity=True,limitx=True ) Local gw = GraphicsWidth() Local gh = GraphicsHeight() Local fh = FontHeight() ; check if x out of bounds If limitx And BPL_Print_\x >= gw BPL_Print_\x = 0 BPL_Print_\y = BPL_Print_\y + fh End If ; new line doesn't fit on screen If limity And BPL_Print_\y >= gh - fh ;BPL_Print_\y = GraphicsHeight() - FontHeight() - 1 BPL_ScrollScreen End If If msg <> "" Text BPL_Print_\x,BPL_Print_\y , msg End If ; carriage return (Print) If cr BPL_Print_\x = 0 BPL_Print_\y = BPL_Print_\y + fh ; cursor behind text (Write) Else BPL_Print_\x = BPL_Print_\x + StringWidth( msg ) End If ; show on screen right away If BPL_PrintFlips = -1 If GraphicsBuffer() = BackBuffer() Flip BPL_FlipVSync If BPL_FlipDelay Delay BPL_FlipDelayTime End If End If ElseIf BPL_PrintFlips = True Flip BPL_FlipVSync If BPL_FlipDelay Delay BPL_FlipDelayTime End If End If End Function ; Function pWrite( msg$ ) pPrint msg , False End Function ; ; note: uses pClsColor's set background color Function BPL_ScrollScreen() Local gw = GraphicsWidth() Local gh = GraphicsHeight() Local fh = FontHeight() ; move all so far up that 1 line will fit CopyRect 0,BPL_Print_\y-gh+fh+1 , gw,gh , 0,0 ; place cursor at last line BPL_Print_\y = gh-fh-1 ; remember current color (minimal system independency) ;Local col_r = ColorRed() ;Local col_g = ColorGreen() ;Local col_b = ColorBlue() ; erase last line (with system-set clscolor) Color BPL_Print_\br,BPL_Print_\bg,BPL_Print_\bb Rect 0,BPL_Print_\y , gw,fh ; restore color ;Color col_r,col_g,col_b Color BPL_Print_\r,BPL_Print_\g,BPL_Print_\b End Function --v stream test 2011-01-24 1c.bb I see only '2' other thingies that are 'missing' in the code that you posted. First, the handler for the "." and ".." folder items (which you catch using a filetype check). Secondly, the check for non-existing files (which is not caught using the same filetype check). Graphics 800,600 , 0,2 Const ScreenWidth = 640 Const ScreenHeight = 480 Graphics ScreenWidth,ScreenHeight , 0,3 ClsColor 0,64,128 Cls Color 192,224,255 Locate 0,ScreenHeight SetFont LoadFont( "FixedSys" ) SeedRnd MilliSecs() Local root$ = "test_target.folder_tester.$$$" Print "Creating root folder" CreateDir root If Not (FileType( root ) = 2) RuntimeError "Unable to create folder: "+root End If Const size = 8 Const count = 5 Local number Local name$ ; make some files (upper case) Print "Creating "+count+" files in root folder" For number = 1 To count name = root+"\"+String_GenerateGarbage( size , 65,90 ) If Not CreateFile( name ) RuntimeError "Unable to create file: "+name End If Next ; make some folders (lower case) Print "Creating "+count+" folders in root folder" For number = 1 To count name = root+"\"+String_GenerateGarbage( size , 97,122 ) CreateDir name If Not (FileType( name ) = 2) RuntimeError "Unable to create folder: "+name End If Next Print String("-",40) ;Local number Local numdirs ; number of folders found Local numfiles ; number of files found Local numwtf ; number of items not found (wtf) Local show$ Local dir = ReadDir( root ) Print "Folder: "+root Print String("-",40) number = 0 Repeat number=number+1 Local item$ = NextFile( dir ) ; no more items (end of list) If item = "" Exit Else Select FileType( root+"\"+item ) Case 0 ; item not found (wtf) numwtf=numwtf+1 show = "Deleted: "+item Case 1 numfiles=numfiles+1 show = "File: "+item+" ("+FileSize(root+"\"+item)+" bytes)" Case 2 numdirs=numdirs+1 show = "Dir: "+item+"\" End Select Print number+". "+show End If Forever CloseDir dir Print String("-",40) Print "Folders: "+numdirs+" Files: "+numfiles+" Other: "+numwtf FlushKeys WaitKey DeleteDirs root End ; create a file with random size Function CreateFile( filename$ ) Local stream = WriteFile( filename ) If stream = 0 Return False End If Local amount = Rand( 10,1000 ) Local bank = CreateBank( amount ) WriteBytes bank,stream , 0,amount FreeBank bank CloseFile stream Return True End Function ;------------------------------------------------------------------------------- Repeat A_FILE$=NextFile(THE_DIR):;Print CK$+" "+F1+" "+F2+" "+FileType(A_FILE$):Goto HALT If FileType(A_FILE$)<>2 ;Or Right$(A_FILE$,3)<>"SAN" CK$=DI$+"\"+A_FILE$:;Print CK$:Goto HALT F1=ReadFile(CK$) F2=ReadFile("PS.DAT") Print CK$+" "+F1+" "+F2 While Not Eof(F1) ; GET.BYTES=New BYTES ; GET\A_BYTE=ReadByte(F1) If Eof(F2) Then SeekFile(F2,0) ;.. Wend ;.. End If Until A_FILE="" ;------------------------------------------------------------------------------- ; Return amount of random chars ; Origin: String.Lib.BB ;------------------------------------------------------------------------------- Function String_GenerateGarbage$( Width=0 , Min=32 , Max=255 ) Local n Local garb$ Local length If Width>0 ; Strict amount For n=1 To Width garb$=garb+Chr( Rand( Min,Max ) ) Next ElseIf Width<0 ; Random amount length=Rand( 1,-Width ) For n=1 To length garb=garb+Chr( Rand( Min,Max ) ) Next EndIf Return garb End Function ;------------------------------------------------------------------------------- ; Wipe an entire directory tree (ignoring files/dirs not deleted) ; Origin: robotix @ 11-01-2011 ;------------------------------------------------------------------------------- Const DeleteDirs_Feedback = False ; write dots for each file/dir Function DeleteDirs( Dir$="." , Level=0 ) ;------------------------------------------------------------------------------- ; - Returns the number of files/dirs NOT deleted (Result starts at 0). ; - Level identifies iteration level (in the tree) ; where level 0 means root. Local DirHandle Local FileName$ Local FileSpec$ Local Result ; Cut trailing backslash If Right( Dir , 1 ) = "\" Dir = Left( Dir , Len( Dir ) - 1 ) End If ; Directory scan DirHandle = ReadDir( Dir ) Repeat FileName = NextFile( DirHandle ) If FileName <> "" If FileName <> "." If FileName <> ".." FileSpec = Dir + "\" + FileName ; It's a sub-directory! If FileType( FileSpec ) = 2 ; Go down one level ; - and add number of files/dirs not deleted Result = Result + DeleteDirs( FileSpec , Level+1 ) ; It's a file! Else ; Delete it DeleteFile FileSpec ; Verify if still there If FileType( FileSpec ) = 1 Result = Result + 1 EndIf If DeleteDirs_Feedback Write "." End If End If End If End If Until FileName = "" ; No more files ; If all files and folders in this folder were deleted If Result = 0 ; Delete this folder as well DeleteDir Dir ; Verify if still there If FileType( Dir ) = 2 Result = Result + 1 EndIf If DeleteDirs_Feedback Write "." End If EndIf Return Result End Function --v folder entry test 2011-01-24 1c.bb I have not previously encountered Blitz bugs with file streams (only network streams ^^), so I'm quite sure the problem can be easily traced in your code. Perhaps if you post some more code, it'll become clearer what's causing the problem. Perhaps dealing with how handles are closed (and opened), and how files are created, written to, or perhaps deleted, while possibly still being in a loop. The above 2 programs show various file and folder handling mechanisms that I did not see in your code which I hope you find beneficial shroom_monk: One of the things I love most about Blitz is that after initial declaration of a variable (e.g. A_FILE$), Blitz no longer demands a identifier's type specification Similarly: Dim MyArray.MyStruct( .. ) and Global Integer% where % is Blitz's default, which can be omitted entirely
Mon, 24 Jan 2011, 14:01
shroom_monk	Teasy One of the things I love most about Blitz is that after initial declaration of a variable (e.g. A_FILE$), Blitz no longer demands a identifier's type specification That's not a good thing! That just encourages sloppy coding! -=-=- A mushroom a day keeps the doctor away... Keep It Simple, Shroom!
Mon, 24 Jan 2011, 14:07
Teasy	\|edit\| LoL A lot of new replies while I was typing! \|edit\| DNA: Do you close the 2nd file (F2) somewhere else in the code? I don't see it being closed in this code (CloseFile). I also do not see the folder being closed (CloseDir). .READIT THE_DIR=ReadDir(DI$) Repeat A_FILE$=NextFile(THE_DIR) If FileType(A_FILE$)<>2 CK$=DI$+"\"+A_FILE$: F1=ReadFile(CK$) F2=ReadFile("PS.DAT") Print CK$+" "+F1+" "+F2 While Not Eof(F1) GET.BYTES=New BYTES GET\A_BYTE=ReadByte(F1) If Eof(F2) Then SeekFile(F2,0) GET\B_BYTE=ReadByte(F2) GET\C_BYTE=GET\A_BYTE + GET\B_BYTE Wend CloseFile(F1) F1=WriteFile(CK$) For GET.BYTES=Each BYTES WriteByte(F1,GET\C_BYTE) Next CloseFile(F1) EndIf Until A_FILE$="" .HALT WaitKey End --v shroom_monk: I come from an overly Strict background
Mon, 24 Jan 2011, 19:46
dna	Here's the entire source for the routine. Graphics 640,480,16,2:AppTitle "HEX":SeedRnd MilliSecs():CK$="CK~TMP.TXT" DI$="L:\PKFU" Type BYTES Field A_BYTE,B_BYTE,C_BYTE End Type THE_DIR=ReadDir(DI$) Repeat A_FILE$=NextFile(THE_DIR): If FileType(A_FILE$)<>2 CK$=DI$+"\"+A_FILE$ F1=ReadFile(CK$):F2=ReadFile("PS.DAT"):Print CK$+" "+F1+" "+F2 While Not Eof(F1) GET.BYTES=New BYTES:GET\A_BYTE=ReadByte(F1):If Eof(F2) Then SeekFile(F2,0) GET\B_BYTE=ReadByte(F2):GET\C_BYTE=GET\A_BYTE + GET\B_BYTE Wend:CloseFile(F1):F1=WriteFile(CK$):For GET.BYTES=Each BYTES:WriteByte(F1,GET\C_BYTE):Next:CloseFile(F1) EndIf Until A_FILE$="" .HALT WaitKey:End --v -=-=- DNA
Tue, 25 Jan 2011, 10:45
dna	These functions you posted are good Teasy. Are there any for font smoothing in B2D? -=-=- DNA
Sun, 30 Jan 2011, 11:55
Teasy	yes, there are many, dna my favorite is my 'textoutline' function, which is kinda slow, but u have full freedom of color choice every frame etc. and it works the same as Blitz's Text function, with some added parameters for colors. i've posted my rendering library here: https://socoder.net/index.php?snippet=25553 which contains that function. i'll demonstrate its usage in this program: Graphics 800,600 , 0,2 Const sw = 320, sh = 240 Graphics sw,sh , 0,3 SetFont LoadFont( "Tahoma" , 16 , True ) SetBuffer BackBuffer() Local backdir = 2 Local backcol = 0 Local r = 64, rdir = 3 Local g = 128, gdir = 2 Local b = 192, bdir = 1 Repeat backcol = backcol + backdir If backcol <= 0 Or backcol >= 254 backdir = -backdir End If ClsColor backcol,backcol,backcol Cls Local cycle For cycle = 1 To 3 r = r + rdir If r <= 1 Or r >= 253 rdir = -rdir End If g = g + gdir If g <= 0 Or g >= 254 gdir = -gdir End If b = b + bdir If b <= 0 Or b >= 255 bdir = -bdir End If Next Local angle# angle = angle + 1 Local px = Sin( angle ) * sw/4 + sw/2 Local py = Sin( angle-90 ) * sh/4 + sh/2 TextOutLine px,py , "The truth is in here" , True,True , r,g,b , r/1.5,g/1.5,b/1.5 Flip Delay 10 Until KeyHit(1) ;esc End ; Like Text() only with 3x3 outline, for example to make white text visible on white background Function TextOutLine( PosX%,PosY% , Message$ , CenterX=False,CenterY=False , InR=255,InG=255,InB=255 , OutR=0,OutG=0,OutB=0 , Separation=1 ) ; 09 sep 2007: ; - swapped inner/outer color (inner color is now white, outer is black) Local X% Local Y% Color OutR,OutG,OutB ; CenterX: 0 = Left justify, 1 = Center, 2 = Right justify If CenterX = 2 PosX = PosX - StringWidth( Message ) CenterX = False EndIf ; CenterY: 0 = Top justify, 1 = Center, 2 = Bottom justify If CenterY = 2 PosY = PosY - StringHeight( Message ) CenterY = False EndIf For X = -1 To 1 For Y = -1 To 1 Text PosX + X * Separation , PosY + Y * Separation , Message , CenterX , CenterY Next Next Color InR,InG,InB Text PosX,PosY , Message , CenterX,CenterY End Function --v textoutline demo - the truth is in here 1a.bb i also created a 'cache text' function which wraps this in a memory inefficient (^^) system to maximize the speed. instead, i recommend the 'lazypro lib' featurette: the cachedraw library which works like this: Function drawhud() If cachedraw( "specialbar1" , 0,sh/2-sh/16 , sw,sh/8 , fill ) drawspecialbar 0,0 , CDW,CDH , fill End If cacheblit End Function --v the rendering happens in a localized way and completely independently so. and the cache is only updated if your specified parameters change. ; CacheDraw Library ; - enables you to prerender and cache images on the fly ; Keywords: easy pretext predraw drawcache imagecache ; Style: LazyPro Library ; Version: Rev 06 ; - version description: non-redundant supershort (low abstr.) ; - bugfixes and optimized ; - example: ; Function drawhud() ; If cachedraw( "specialbar1" , 0,sh/2-sh/16 , sw,sh/8 , fill ) ; drawspecialbar 0,0 , CDW,CDH , fill ; End If ; cacheblit ; End Function Type cachedimage Field identifier$ Field parameters$ Field image Field imagebuffer Field x,y Field w,h Field changed End Type Global CDX,CDY Global CDW,CDH Global activecachedimage.cachedimage Global cachedraw_rememberbuffer Global cachedraw_bufferchanged Function findcachedimage.cachedimage( identifier$ ) Local p.cachedimage For p = Each cachedimage If p\identifier = identifier Return p End If Next End Function Function cachedraw( identifier$ , x,y , w,h , parameters$="" ) Local p.cachedimage p = findcachedimage( identifier ) If p = Null p = New cachedimage p\identifier = identifier p\x = x p\y = y p\w = w p\h = h p\image = CreateImage( w,h ) p\imagebuffer = ImageBuffer( p\image ) p\changed = True Else If p\w <> w Or p\h <> h p\w = w p\h = h FreeImage p\image p\image = CreateImage( w,h ) p\imagebuffer = ImageBuffer( p\image ) p\changed = True Else p\changed = False End If End If If parameters <> p\parameters p\parameters = parameters p\changed = True End If If p\changed cachedraw_rememberbuffer = GraphicsBuffer() cachedraw_bufferchanged = True SetBuffer p\imagebuffer Cls CDX = p\x CDY = p\y CDW = p\w CDH = p\h Else p\x = x p\y = y End If activecachedimage = p Return p\changed End Function Function cacheblit() If cachedraw_bufferchanged cachedraw_bufferchanged = False SetBuffer cachedraw_rememberbuffer End If DrawImage activecachedimage\image , activecachedimage\x,activecachedimage\y activecachedimage\changed = False End Function --v cachedraw 1b.bb a real font smoothing function is for example my 'font shaper live' also featured in my game called terra colony. originally written in 2003, and suited especially for making fixed-width fonts look great! this code includes demonstration: ; font shaper live ( smooth fonts on the fly in blitz2d ) ; demonstration from 2003 ; teasy <TheChange@yahoo.com> ; fixed-width fonts only version Graphics 800,600 , 0,2 Graphics 400,300 , 0,3 ;<-- Font creation Const FontSizeX = 12 Const FontSizeY = 16 Const FontColorR = 128 Const FontColorG = 192 Const FontColorB = 255 Const BackColorR = 0 Const BackColorG = 0 Const BackColorB = 0 FontImage = CreateImage ( FontSizeX , FontSizeY , 256 ) TextFont = LoadFont ( "Tahoma" , 13 , True ) SetFont TextFont GenerateFont FontImage MaskImage FontImage , BackColorR,BackColorG,BackColorB ;<-- Demo the font SetBuffer BackBuffer() ClsColor 0,64,128 Cls For Iterator = 0 To 255 PrintText ( Iterator Mod 32 ) * FontSizeX , Iterator / 32 * FontSizeY , Chr ( Iterator ) , FontImage Next Flip FlushKeys Repeat If shown PrintText 10,GraphicsHeight()-FontSizeY-11 , "Press <ESC> to exit" , FontImage Else Color 0,64,128 Rect 10,GraphicsHeight()-FontSizeY-11 , GraphicsWidth(),FontSizeY EndIf shown = Not shown Flip Delay 125 Until KeyHit(1) End ;--> Function GenerateFont ( FontImage ) TextFontSizeX = StringWidth ( "W" ) TextFontSizeY = FontHeight () TFormFilter True For Character = 0 To 255 CharImage = CreateImage ( TextFontSizeX , TextFontSizeY ) SetBuffer ImageBuffer ( CharImage ) ClsColor BackColorR , BackColorG , BackColorB Cls Color FontColorR , FontColorG , FontColorB Text TextFontSizeX/2 , TextFontSizeY/2 , Chr ( Character ) , True,True ResizeImage CharImage , FontSizeX , FontSizeY SetBuffer ImageBuffer ( FontImage , Character ) DrawImage CharImage , 0 , 0 FreeImage CharImage Next End Function Function PrintText ( x , y , t$ , FontImage = 0 ) If FontImage For i = 1 To Len ( t ) DrawImage FontImage , x + (i-1) * FontSizeX , y , Asc ( Mid ( t , i , 1 ) ) Next End If End Function --v Font Shaper Live 1b.bb and finally, something really fancy (yet simple), a dynamic font bitmapper (on the fly) which takes any fixed or variable width font and scales and colorizes it to your liking with 'lazylib' style interface. code includes demonstration: ; variable font width library ; - can be used to convert text to images for a major drawing speed up ; - can also be used to smooth fonts on the fly ; - supports also fixed width fonts ; see demonstration program at the bottom ; usage: ; SetFont LoadFont( "Arial" ) ; arial.FontType = CreateFont() ; SelectFont arial ; DrawFont 0,0 , "I love you" ; advanced usage: ; SetFont LoadFont( "Tahoma" , 24 , False ) ; TFormFilter True ; tahoma.FontType = CreateFont( 12,16 ) ; more options -> see example program ; SelectFont tahoma ; DrawFont 320,240 , "Window Center" , True,True ; created by Teasy <TheChange@yahoo.com> ; last modified: 29 Jan 2011 ;------------------------------------------------------------------------------- Type FontType Field Image[255] Field Width[255] Field Height ; this is the same height for each character Field MaxWidth ; widest character in the font set Field FixedWidth ; true if this font is fixed width, false if width is variable End Type Global ActiveFontType.FontType ; generate a set of rendered font images with custom settings Function CreateFont.FontType( target_width=0,target_height=0 , font_rgb=$FFFFFF,back_rgb=0 , kerning_char$="m" ) ; Param target_width,target_height ; ; using these you can scale the font to achieve font smoothing, ; ; or you can simply leave one (or both) to 0 to keep the original font size. ; ; setting both to 0 converts Text into images for a nice drawing speed up. ; Param font_rgb ; ; this is the font's foreground color, for example $80C0FF is light blue. ; Param back_rgb ; ; this is the background color, which also becomes the mask. ; ; when scaling/smoothing the font, this can be set to a 'neutral' color, ; ; for example grey-ish or medium-brightness color. ; Param kerning_char ; ; kerning determines the space between characters (for variable width fonts) ; ; so using this you can bring the characters closer together or further away. Local fonttype.FontType Local char Local width Local old_buffer Local kerning Local char_width fonttype = New FontType width = StringWidth( "W" ) If width = StringWidth( "." ) = StringWidth( "\|" ) = StringWidth( "_" ) fonttype\FixedWidth = True fonttype\MaxWidth = width Else kerning = StringWidth( kerning_char ) End If fonttype\Height = FontHeight() If target_height <= 0 target_height = fonttype\Height End If old_buffer = GraphicsBuffer() For char = 0 To 255 If fonttype\FixedWidth fonttype\Width[ char ] = fonttype\MaxWidth Else fonttype\Width[ char ] = StringWidth( Chr(char) ) End If fonttype\Image[ char ] = CreateImage( fonttype\Width[char],fonttype\Height ) MaskImage fonttype\Image[ char ] , 0,0,back_rgb SetBuffer ImageBuffer( fonttype\Image[char] ) Color 0,0,back_rgb Rect 0,0 , fonttype\Width[char],fonttype\Height , True Color 0,0,font_rgb Text fonttype\Width[char]/2,fonttype\Height/2 , Chr(char) , True,True ; resize font (with smoothing) If target_width > 0 ; fixed font -> scale to target (all chars same size) If fonttype\FixedWidth char_width = target_width ; var font -> scale to target (every char different size) Else char_width = fonttype\Width[char] * target_width / kerning End If ResizeImage fonttype\Image[ char ] , char_width,target_height ; no resize Else ; fixed/var font -> keep original size char_width = fonttype\Width[char] End If fonttype\Width[char] = char_width If fonttype\Width[ char ] > fonttype\MaxWidth fonttype\MaxWidth = fonttype\Width[ char ] End If Next fonttype\Height = target_height SetBuffer old_buffer Return fonttype End Function ; draw custom text on screen (just like Text function) Function DrawFont( pos_x,pos_y , msg_text$ , center_x=False,center_y=False ) ; Param center_x ; 0 = left-align, 1 = center, 2 = right-align ; Param center_y Local length Local char Local pixel_width Local preset ; use preset table Local table[256] If ActiveFontType = Null Return End If If msg_text = "" Return End If length = Len( msg_text ) If length > 256 msg_text = Left( msg_text , 256 ) length = 256 End If If center_x > 0 If ActiveFontType\FixedWidth pixel_width = ActiveFontType\MaxWidth Else preset = True For char = 1 To length table[ char ] = Asc( Mid( msg_text , char,1 ) ) pixel_width = pixel_width + ActiveFontType\Width[ table[char] ] Next End If Select center_x Case 1 pos_x = pos_x - pixel_width / 2 Case 2 pos_x = pos_x - pixel_width End Select End If Select center_y Case 1 pos_y = pos_y - ActiveFontType\Height / 2 Case 2 pos_y = pos_y - ActiveFontType\Height End Select For char = 1 To length If Not preset table[ char ] = Asc( Mid( msg_text , char,1 ) ) End If ;DebugLog "draw pos "+char+" char "+table[ char ]+" img "+ActiveFontType\Image[ table[char] ]+" x "+pos_x+" y "+pos_y DrawImage ActiveFontType\Image[ table[char] ] , pos_x,pos_y pos_x = pos_x + ActiveFontType\Width[ table[char] ] Next End Function ; select a font for drawing (DrawFont) Function SelectFont( fonttype.FontType ) ActiveFontType = fonttype End Function ;------------------------------------------------------------------------------- Graphics 800,600 , 0,2 Graphics 400,300 , 0,3 SetBuffer BackBuffer() ClsColor 0,32,64 Cls Color 0,32,64 Rect 0,0 , 400,300 , False ; choose the original font to use (blueprint) SetFont LoadFont( "Tahoma" , 24 ) ;SetFont LoadFont( "FixedSys" ) ; <-- fixed width fonts work well too! ; use font smoothing (in resize) TFormFilter True ; create the font with specific dimensions and color Local Tahoma.FontType = CreateFont( 12,16 , $C0E0FF , $607080 ) ; make the new font the active font SelectFont Tahoma ; display a character map Local w=12,h=16 Local char,x,y For char = 0 To 255 x = w + ( char Mod 32 ) * w y = h + char / 32 * h DrawFont x,y , Chr(char) , True,True Next ; and some demonstration text DrawFont 10,GraphicsHeight()-10 , "Press <ESC> to exit (100%!)" , False,2 Flip FlushKeys WaitKey End --v flyfontlib 1e.bb enjoy!
Mon, 31 Jan 2011, 09:54
dna	Are some of these written in BMax? I get a memory access violation ** I got most of these to run except for the vari font lib which still gives me a memory access violation. These work but all have jaggies much worse than the normal B2D loadfont at any size. The problem I was having entailed having jaggies only around the edge. -=-=- DNA
Tue, 01 Feb 2011, 12:44
Teasy	nope, none for blitzmax. do u get the error with debug mode turned on? if so, where does the error occur?
Wed, 02 Mar 2011, 19:57
dna	I got the font to display but it is not pretty like your terra colony. Perhaps something I'm not setting? -=-=- DNA