PureBasic Forums - English

http://www.purebasic.com
https://www.purebasic.fr/english/

ID generator : simulate #PB_Any

https://www.purebasic.fr/english/viewtopic.php?t=38346

Page 1 of 1

ID generator : simulate #PB_Any

Posted: Thu Jul 30, 2009 12:39 am
by eddy

Code: Select all

CompilerIf #PB_Compiler_Debugger
   Import ""
      CompilerIf Defined(PB_DEBUGGER_SendWarning, #PB_Procedure)=0
         PB_DEBUGGER_SendWarning(Message.p-ascii)
      CompilerEndIf
      CompilerIf Defined(PB_DEBUGGER_SendError, #PB_Procedure)=0
         PB_DEBUGGER_SendError(Message.p-ascii)
      CompilerEndIf
   EndImport
CompilerElse
   Macro PB_DEBUGGER_SendWarning(Message)
   EndMacro
   Macro PB_DEBUGGER_SendError(Message)
   EndMacro
CompilerEndIf

Structure OBJ
   ID.i
   type.s{256}
   *handle
   ;
   ; HERE YOUR CUSTOM PARAMETERS...
   ;
   a.i
   b.i
   c.i
EndStructure
Global NewList OBJ.OBJ()
#OBJ_TYPE$="Custom Object Type"

Procedure.i CreateObjectHandle(a, b, c)
   ;
   ; HERE YOUR CUSTOM HANDLE MAKER...
   ;
   *handle=AllocateMemory(1000)
   PokeS(*handle, Str(a+b+c))
   ProcedureReturn *handle
EndProcedure
Procedure.i CreateObject(ID, a, b, c)
   Protected result
   
   If ID>=0 And ID<=100000
      AddElement(OBJ())
      OBJ()\ID=ID
      OBJ()\handle=CreateObjectHandle(a, b, c)
      OBJ()\type=#OBJ_TYPE$
      result=OBJ()\handle
   ElseIf ID=#PB_Any
      OBJ()\ID=AddElement(OBJ())
      OBJ()\handle=CreateObjectHandle(a, b, c)
      OBJ()\type=#OBJ_TYPE$
      result=OBJ()\ID
   Else
      PB_DEBUGGER_SendError("#ID is out of range (0-100000)")
      ProcedureReturn #False
   EndIf
   ;
   ; HERE SAVE YOUR CUSTOM PARAMETERS
   ;
   OBJ()\a=a
   OBJ()\b=b
   OBJ()\c=c
   
   ProcedureReturn result
EndProcedure

Procedure.i IsObject(ID)
   If ListSize(OBJ())
      If ID>=FirstElement(OBJ())
         ;quick search (#PB_ANY)
         ChangeCurrentElement(OBJ(), ID)
         If OBJ()\type=#OBJ_TYPE$
            ProcedureReturn @OBJ()
         EndIf
      Else
         ;slow search
         If OBJ()\ID=ID And OBJ()\type=#OBJ_TYPE$
            ProcedureReturn @OBJ()
         Else 
            ForEach OBJ()
               If OBJ()\ID=ID And OBJ()\type=#OBJ_TYPE$
                  ProcedureReturn @OBJ()
               EndIf
            Next
         EndIf 
      EndIf
   EndIf
   
   ProcedureReturn #False
EndProcedure
Procedure.i ObjectID(ID)
   *ThisObj.OBJ=IsObject(ID)
   If *ThisObj
      ProcedureReturn *ThisObj\handle
   Else
      ProcedureReturn #False
   EndIf
EndProcedure

*ObjectID=CreateObject(10, 1, 2, 3)
Debug *ObjectID
Debug ObjectID(10)
Debug PeekS(*ObjectID)    ;<--- 6
Debug PeekS(ObjectID(10)) ;<--- 6
*ThisObj.OBJ=IsObject(10)
Debug *ThisObj\a
Debug *ThisObj\b
Debug *ThisObj\c
Debug ""
ID=CreateObject(#PB_Any, 10, 20, 30)
*ThisObj.OBJ=IsObject(ID)
Debug *ThisObj\a
Debug *ThisObj\b
Debug *ThisObj\c
Debug PeekS(*ThisObj\handle) ;<--- 60
Debug PeekS(ObjectID(ID))    ;<--- 60
Debug ""
;*ObjectID=CreateObject(10000000000, 1, 2, 3) <--- test error message

Posted: Fri Jul 31, 2009 5:17 am
by Hroudtwolf
Hi,

Thats a cool idea and a good solution.
But not very dynamicly and therefore only for single usage usable.

Once, I developed a dynamic solution.

Code: Select all

EnableExplicit

#OBJECT_ANY = -1

Prototype.i pCallOnRelease ( *ptrObject , iParam.i )

Structure tObjectManager_Item
   *ptrObject
   blInUse        .l
   *CallOnRelease .pCallOnRelease
   iParamOnRelease.i
EndStructure

Structure tObjectManager
   Object   .tObjectManager_Item [ $FFFF ]
   nObjects .l
EndStructure

Procedure eObjectManager_CreateEnvironment ()

   ProcedureReturn AllocateMemory ( SizeOf ( tObjectManager ) )
EndProcedure

Procedure.i eObjectManager_Alloc ( *Env.tObjectManager , iID.i ,*ptrObject , *CallOnRelease = #Null , iParamOnRelease.i = #Null )
   Protected nCount.l
   
   If iID > $FFFE
      ProcedureReturn #Null
   EndIf
   
   If Not ( iID = #OBJECT_ANY )
      If *Env\Object [ iID ]\blInUse And *Env\Object [ iID ]\CallOnRelease
         *Env\Object [ iID ]\CallOnRelease ( *Env\Object [ iID ]\ptrObject , *Env\Object [ iID ]\iParamOnRelease )
      EndIf
      
      *Env\Object [ iID ]\ptrObject       = *ptrObject
      *Env\Object [ iID ]\CallOnRelease   = *CallOnRelease
      *Env\Object [ iID ]\iParamOnRelease = iParamOnRelease
 
      ProcedureReturn #True
   EndIf
   
   For nCount = 0 To $FFFE
      If Not *Env\Object [ nCount ]\blInUse
         
         *Env\Object [ nCount ]\ptrObject       = *ptrObject
         *Env\Object [ nCount ]\CallOnRelease   = *CallOnRelease
         *Env\Object [ nCount ]\iParamOnRelease = iParamOnRelease
         *Env\Object [ nCount ]\blInUse         = #True
         
         ProcedureReturn *ptrObject
      EndIf
   Next nCount
   
   ProcedureReturn #Null
EndProcedure

Procedure.i eObjectManager_GetObject ( *Env.tObjectManager , iID.i )
   Protected nCount.l
   
   If iID > $FFFE
       For nCount = 0 To $FFFE
          If *Env\Object [ nCount ]\ptrObject = iID And *Env\Object [ nCount ]\blInUse
             ProcedureReturn *Env\Object [ nCount ]\ptrObject
          EndIf
       Next nCount
       
       ProcedureReturn #Null
   EndIf
   
   
   ProcedureReturn *Env\Object [ iID ]\ptrObject
EndProcedure

Procedure.l eObjectManager_FreeObject ( *Env.tObjectManager , iID.i )
   Protected nCount.l
   
   If iID > $FFFE
       For nCount = 0 To $FFFE
          If *Env\Object [ nCount ]\ptrObject = iID And *Env\Object [ nCount ]\blInUse
             If *Env\Object [ nCount ]\CallOnRelease 
                *Env\Object [ nCount ]\CallOnRelease ( *Env\Object [ nCount ]\ptrObject  , *Env\Object [ nCount ]\iParamOnRelease )
             EndIf
             *Env\Object [ nCount ]\blInUse = #False   
             ProcedureReturn #True
          EndIf
       Next nCount
       
       ProcedureReturn #Null
   EndIf
   
   If *Env\Object [ iID ]\CallOnRelease 
      *Env\Object [ iID ]\CallOnRelease ( *Env\Object [ iID ]\ptrObject  , *Env\Object [ iID ]\iParamOnRelease )
   EndIf
   *Env\Object [ iID ]\blInUse = #False
   
   ProcedureReturn #True
EndProcedure

Procedure.i eObjectManager_CloneObject ( *Env.tObjectManager , iID.i )
   Protected *Object.tObjectManager_Item = eObjectManager_GetObject ( *Env, iID )
   
   If Not *Object
      ProcedureReturn #False
   EndIf

   ProcedureReturn eObjectManager_Alloc ( *Env , #OBJECT_ANY , *Object\ptrObject , *Object\CallOnRelease , *Object\iParamOnRelease )
EndProcedure




;---- Testlib

Procedure _Test_LibraryProc ()
   Static *Environment
   
   If Not *Environment
       *Environment = eObjectManager_CreateEnvironment ()
   EndIf
   
   ProcedureReturn *Environment
EndProcedure

Procedure _Test_FreeProc ( *ptrObject , iParam.i )

   Debug "Object freigegeben."
   FreeMemory ( *ptrObject )
   
   ProcedureReturn #Null
EndProcedure

Procedure.i Test_Create ( iID.i , sParameter.s )
   Protected *Environment = _Test_LibraryProc ()
   Protected *ptrObject   = AllocateMemory ( MemoryStringLength ( @ sParameter ) ) ; Just a testobject
   
   PokeS ( *ptrObject , sParameter )
   
   ProcedureReturn eObjectManager_Alloc ( *Environment , iID , *ptrObject , @ _Test_FreeProc () , #Null )
EndProcedure

Procedure.s Test_Get ( iID.i )
   Protected *Environment = _Test_LibraryProc ()
   Protected *ptrObject   = eObjectManager_GetObject ( *Environment , iID )

   If Not *ptrObject  
      ProcedureReturn ""
   EndIf
   
   ProcedureReturn PeekS ( *ptrObject )
EndProcedure

Procedure.l Test_Free ( iID.i )
   Protected *Environment = _Test_LibraryProc ()
   
   ProcedureReturn eObjectManager_FreeObject ( *Environment , iID )
EndProcedure

Define.i iID0
Define.i iID1
Define.i iID2

iID0 = Test_Create ( #OBJECT_ANY , "Hallo Welt" )
iID1 = Test_Create ( #OBJECT_ANY , "Ola mundo" )
iID2 = Test_Create ( #OBJECT_ANY , "Ciao mondo" )

Test_Create ( 3 , "Hallo Welt" )

Debug Test_Get ( iID0 )
Debug Test_Get ( iID1 )
Debug Test_Get ( iID2 )
Debug Test_Get ( 3 )

Test_Free ( iID0 )
Test_Free ( iID1 )
Test_Free ( iID2 )
Best regards
Wolf

Posted: Fri Jul 31, 2009 9:55 pm
by eddy
Your solution is better. I'll try to improve mine.

Posted: Fri Jul 31, 2009 11:41 pm
by eddy

Code: Select all

CompilerIf Defined(MANAGER_ManageObjects, #PB_Procedure)=0
   EnableExplicit
   CompilerIf #PB_Compiler_Debugger
      Import ""
         CompilerIf Defined(PB_DEBUGGER_SendWarning, #PB_Procedure)=0
            PB_DEBUGGER_SendWarning(Message.p-ascii)
         CompilerEndIf
         CompilerIf Defined(PB_DEBUGGER_SendError, #PB_Procedure)=0
            PB_DEBUGGER_SendError(Message.p-ascii)
         CompilerEndIf
      EndImport
   CompilerElse
      Macro PB_DEBUGGER_SendWarning(Message)
      EndMacro
      Macro PB_DEBUGGER_SendError(Message)
      EndMacro
   CompilerEndIf
   
   Macro MANAGER_ManageObjects(OBJECT, MAX=$FFFF)
      Structure MANAGER_#OBJECT
         *handle.OBJECT[2*MAX+1]
         used.b[2*MAX+1]
         count.i
         last.i
         anyfirst.i
         anylast.i
         current.i
      EndStructure
      Global MANAGER_#OBJECT.MANAGER_#OBJECT
      MANAGER_#OBJECT\last=MAX
      MANAGER_#OBJECT\anyfirst=MAX+1
      MANAGER_#OBJECT\anylast=2*MAX
   EndMacro
   Macro MANAGER_GetObjectHandle(OBJECT, ID)
      MANAGER_#OBJECT\handle[ID]
   EndMacro
   Macro MANAGER_GetObjectCount(OBJECT)
      MANAGER_#OBJECT\count
   EndMacro
   Macro MANAGER_GetObjectCurrent(OBJECT)
      MANAGER_#OBJECT\current
   EndMacro
   Macro MANAGER_CountObjects(OBJECT)
      ProcedureReturn MANAGER_#OBJECT\count
   EndMacro
   Macro MANAGER_IsObject(OBJECT, ID)
      If ID>=0 And ID<=MANAGER_#OBJECT\anylast
         ProcedureReturn MANAGER_#OBJECT\used[ID]
      EndIf
   EndMacro
   Macro MANAGER_UseObject(OBJECT, ID, NotValidError="[#ID={0}] : the specified object #ID is not valid!")
      If (ID>=0 And ID<=MANAGER_#OBJECT\anylast) And MANAGER_#OBJECT\used[ID]
         MANAGER_#OBJECT\current=ID
         ProcedureReturn MANAGER_#OBJECT\current
      ElseIf ID=#PB_Ignore
         ProcedureReturn MANAGER_#OBJECT\current
      Else
         PB_DEBUGGER_SendError(ReplaceString(NotValidError, "{0}", Str(ID)))
      EndIf
   EndMacro
   Macro MANAGER_ObjectID(OBJECT, ID, NotInitializedError="[#ID={0}] : the specified object #ID is not initialized!")
      If (ID>=0 And ID<=MANAGER_#OBJECT\anylast) And MANAGER_#OBJECT\used[ID]
         ProcedureReturn MANAGER_#OBJECT\handle[ID]
      Else
         PB_DEBUGGER_SendError(ReplaceString(NotInitializedError, "{0}", Str(ID)))
      EndIf
   EndMacro
   Macro MANAGER_FreeObject(OBJECT, ID)
      FreeMemory(MANAGER_#OBJECT\handle[ID])
      MANAGER_#OBJECT\handle[ID]=#Null
      MANAGER_#OBJECT\used[ID]=#False
      MANAGER_#OBJECT\count-1
   EndMacro
   Macro MANAGER_CreateObject(OBJECT, ID, RESULT, FreeObject, OutOfRangeError="[#ID={0}] : #ID object number is out of range (0 - {1})")
      Protected RESULT=#Null
      If ID=#PB_Any
         For ID=MANAGER_#OBJECT\anyfirst To MANAGER_#OBJECT\anylast
            If Not MANAGER_#OBJECT\used[ID]
               MANAGER_#OBJECT\used[ID]=#True
               MANAGER_#OBJECT\handle[ID]=AllocateMemory(SizeOf(OBJECT))
               MANAGER_#OBJECT\count+1
               RESULT=ID
               Break
            EndIf
         Next
      ElseIf ID>=0 And ID<=MANAGER_#OBJECT\last
         If MANAGER_#OBJECT\used[ID]
            FreeObject(ID)
         EndIf
         MANAGER_#OBJECT\used[ID]=#True
         MANAGER_#OBJECT\handle[ID]=AllocateMemory(SizeOf(OBJECT))
         MANAGER_#OBJECT\count+1
         RESULT=MANAGER_#OBJECT\handle[ID]
      Else
         PB_DEBUGGER_SendError(ReplaceString(ReplaceString(OutOfRangeError, "{0}", Str(ID)), "{1}", Str(MANAGER_#OBJECT\last)))
      EndIf
   EndMacro
CompilerEndIf

; **************************
; Test Lib
; **************************
Structure THING
   a.i
   b.i
   content.s
EndStructure
MANAGER_ManageObjects(THING, 5000)
Procedure.i CountThings()
   MANAGER_CountObjects(THING)
EndProcedure
Procedure.i ThingID(ID)
   MANAGER_ObjectID(THING, ID)
EndProcedure
Procedure.i UseThing(ID=#PB_Ignore)
   MANAGER_UseObject(THING, ID)
EndProcedure
Procedure.b IsThing(ID)
   MANAGER_IsObject(THING, ID)
EndProcedure
Procedure FreeThing(ID)
   ;
   ; HERE : CODE BEFORE OBJECT DELETION
   ;
   Protected *ThingHandle.THING=MANAGER_GetObjectHandle(THING, ID)
   Debug "FreeThing : Content = "+*ThingHandle\content
   
   MANAGER_FreeObject(THING, ID)
EndProcedure
Procedure CreateThing(ID, a, b)
   ;
   ; HERE : CODE TO VALIDATE ALL PARAMETERS
   ;
   If a=0 And b=0
      ProcedureReturn #Null
   EndIf
   
   MANAGER_CreateObject(THING, ID, result, FreeThing)
   If result
      ;
      ; HERE : CODE TO CUSTOMIZE AND SAVE OBJECT HANDLE
      ;
      Protected *ThingHandle.THING=MANAGER_GetObjectHandle(THING, ID)
      *ThingHandle\a=a
      *ThingHandle\b=b
      *ThingHandle\content="{a -> "+Str(a)+", b ->"+Str(b)+"}"
      Debug "CreateThing : Content = "+*ThingHandle\content
      
      ProcedureReturn result
   EndIf
EndProcedure

Debug CreateThing(100, 1, 0)
Debug CreateThing(100, 0, 2)
Debug ThingID(100)
Debug "count="+Str(CountThings())
Debug IsThing(100)
FreeThing(100)
Debug "count="+Str(CountThings())
Debug IsThing(100)
Debug ""

Debug CreateThing(#PB_Any, 1, 2)
Global newID=CreateThing(#PB_Any, 1, 1)
If IsThing(newID)
   Debug newID
   Debug ThingID(newID)
   Global *ThingHandle.THING=ThingID(newID)
   Debug *ThingHandle\content
   Debug "count="+Str(CountThings())
EndIf

Posted: Sat Aug 01, 2009 5:41 am
by PB
Why all this code when #PB_Any will do it? Is #PB_Any buggy or something?

Posted: Sat Aug 01, 2009 7:30 am
by Hroudtwolf
First, why not?
And...
A self-coded solution ever is custom-made.
Also, nobody is realy able to anticipate the changes by development of the internal PureBasic objectmanager.
So, such solutions are resistent for longer time.

A proper man will built his house by him-self. ;-)

Regards
Wolf

Posted: Sat Aug 01, 2009 11:07 am
by PB
> First, why not?

Because it's re-inventing the wheel?

> nobody is realy able to anticipate the changes by development of the
> internal PureBasic objectmanager

:roll: So, what, are you going to replace OpenWindow with an API solution
too, just in case OpenWindow has some unknown future changes? It's
not going to change in the alarmist manner that you're describing. Relax.

But I agree that yes, it's a good programming exercise. I just don't think
it's necessarily something that needs to be done to future-proof your app.
If you were using a third-party library, then yes, but not PureBasic's code.

BTW, I'm only bringing this up for the benefit of newbies and lurkers who
may be reading this thread, because such comments by yourself can give
them a false view of the language, which is not good advertising.

Posted: Sat Aug 01, 2009 11:22 am
by Hroudtwolf
BTW, I'm only bringing this up for the benefit of newbies and lurkers who
may be reading this thread, because such comments by yourself can give
them a false view of the language, which is not good advertising.
I am amazed.
'Cause, the codes in this thread shows a lot of possibilities with purebasic.

Posted: Sat Aug 01, 2009 11:24 am
by PB
Yes, the code shows the possibilities, but people might read your comments
about the development changes and decide that PureBasic is too unstable
to buy. That's all I meant. If I read that, that's what I'd think.

Posted: Sat Aug 01, 2009 11:42 am
by Hroudtwolf
Well. This wasn't my statement.
It is just what you read.

Posted: Sat Aug 01, 2009 12:10 pm
by eddy

Code: Select all

Why all this code when #PB_Any will do it? Is #PB_Any buggy or something?
Because I'm coding a custom sprite 3D lib and I need a #PB_any-like functionality.

CreateCustomSprite(PB_any,....)
All times are UTC+01:00
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited