IsAnagram()

[ar-s]

Hi,

For a little contest, i have made that procedure wich check if two stings are anagrams.

Code: Select all

;- IsAnagram(SourceString.s,DicoString.s)

Procedure.b IsAnagram(SourceString.s,DicoString.s)
  ; Libs ANAGRAMMES by Ar-S / 2011
  
  Protected.l NbrCarSource,NbrCarString,Trouve,cherche
  Protected.s LettreSource
  
  NbrCarSource = Len(SourceString)
  NbrCarDico = Len(DicoString)
  Trouve = 0
  
  If NbrCarSource <> NbrCarDico
    ProcedureReturn #False
    
  Else  
    For i = 1 To NbrCarSource
      LettreSource = Mid(SourceString,i,1)
      cherche = FindString(DicoString,LettreSource,1)
      
      If cherche = 0
        ProcedureReturn #False
      Else  
        Trouve + 1

        If Trouve = NbrCarSource
          ProcedureReturn #True
        Else
          DicoString = RemoveString(DicoString, LettreSource, 0, 1, 1)
        EndIf
        
      EndIf
    Next i
  EndIf
EndProcedure

Here is an example

Code: Select all

; IsAnagram() par Ar-S / 2011
; More usefull stuff in my Ar-S Lib : http://forumpb.ldvmultimedia.com/index.php?topic=22.msg40


If IsAnagram("PURE BASIC","CUBE SARIP")
  MessageRequester("Oh yeah","Both words are anagram")
Else
  MessageRequester("Nop !","There is no anagram")
EndIf

CyA

[gnasen]

looks interesting, but i really try to avoid string operations. I pretty often get some brain error induced bugs with them You could do it like this with an array for example:

Code: Select all

Procedure isAnagram(string1.s,string2.s)
  
  Protected len.i = Len(string1)
  
  If len <> Len(string2)
    ProcedureReturn #False
  EndIf
  
  Dim char1.i(len-1)
  Dim char2.i(len-1)
  
  For a=0 To len-1
    char1(a) = PeekB(@string1+a)
    char2(a) = PeekB(@string2+a)
  Next
  
  SortArray(char1(),#PB_Sort_Ascending)
  SortArray(char2(),#PB_Sort_Ascending)
  
  For a=0 To len-1
    If char1(a) <> char2(a)
      ProcedureReturn #False
    EndIf
  Next
  
  ProcedureReturn #true
  
EndProcedure

By the way: Are anagrams case sensitiv?

[ar-s]

Hi, Thanks for your code,
For the case sensitiv question, it was only numbers in my contest, but it have to.
I simply use a Debug IsAnagram(LCase("EpURE"),LCase("UPREE")) for example.

[Demivec]

@Edit: removed code (posted due to light headedness )

[eesau]

Demivec, that doesn't do the same thing, yours checks for palindromes.

[Demivec]

Demivec, that doesn't do the same thing, yours checks for palindromes.

Your correct, I realised my foolishness too late to correct the mistake before your posting.

Thanks for the heads-up anyway.

I've done some postings in this regard in the past here.

[Danilo]

What about this?

Code: Select all

CompilerIf #PB_Compiler_Unicode
    #numChars = $FFFF
CompilerElse
    #numChars = $FF
CompilerEndIf

Global Dim sourceChars.c( #numChars )
Global Dim destChars  .c( #numChars )

Procedure IsAnagram(SourceString.s,DicoString.s)
    Protected *source.Character = @SourceString
    Protected *dest.Character   = @DicoString

    Protected x.c = *source\c
    
    While x
        sourceChars(x) + 1
        *source+SizeOf(Character)
        x = *source\c
    Wend
    
    x.c = *dest\c

    While x
        destChars(x) + 1
        *dest+SizeOf(Character)
        x = *dest\c
    Wend
    
    retval = CompareMemory(@sourceChars(),@destChars(),#numChars)

    FillMemory(@sourceChars(), #numChars+1)
    FillMemory(@destChars()  , #numChars+1)

    ProcedureReturn retval
EndProcedure

Debug IsAnagram(LCase("EpURE"),LCase("UPREE"))
Debug IsAnagram("hello","world")
Debug IsAnagram("orwld","world")

If IsAnagram("PURE BASIC","CUBE SARIP")
  MessageRequester("Oh yeah","Both words are anagram")
Else
  MessageRequester("Nop !","There is no anagram")
EndIf

It just counts how often each (unicode-)character is in the strings
and compares the memory.

[Demivec]

@Danillo: Your code doesn't clear the global arrays. If you do a test for non-anagrams then all tests are unreliablel afterwards because they are adding to old tallys.

Here's a solution that is similar to Danilo's, though different:

Code: Select all

Procedure sortLettersInPlace(*word.Character, wordLength) ;sorts the letters of a word without creating a new string
  Protected Dim letters.c(wordLength)
  Protected *letAdr = @letters()
  
  CopyMemoryString(*word, @*letAdr)
  SortArray(letters(), #PB_Sort_Ascending, 0, wordLength - 1)
  CopyMemoryString(@letters(), @*word)
EndProcedure

Procedure isAnagram(SourceString.s, DicoString.s)
  sortLettersInPlace(@SourceString, Len(SourceString))
  sortLettersInPlace(@DicoString, Len(DicoString))
  If SourceString =DicoString
    ProcedureReturn #True
  EndIf
  ProcedureReturn #False
EndProcedure

If isAnagram("PURE BASIC","CUBE SARIP")
  MessageRequester("Yup!","Both words are anagrams.")
Else
  MessageRequester("Nop!", "Words are not anagrams.")
EndIf

It works for unicode or ascii and requires no big global arrays.

[luis]

Hi, another variant (ascii only obviously) without string operations.

Code: Select all

a$ = "pure basic"
b$ = "preuabic s"


Procedure.i IsAnagram(a$, b$)
 Protected l, i
 Protected *a.Character, *b.Character
 Protected Dim ac(256), Dim bc(256)
 
 l = Len(a$) : If l <> Len(b$) : ProcedureReturn 0 : EndIf
 
 *a = @a$
 *b = @b$
 
 For i = 1 To l
     ac(*a\c) + 1 : *a + 1 
     bc(*b\c) + 1 : *b + 1          
 Next
 
 ProcedureReturn CompareMemory(@ac(), @bc(), 256 * SizeOf(Integer))      
EndProcedure

Debug IsAnagram(a$, b$)

EDIT: oh, someone else already did something similar I see

[helpy]

Here is mine:

Code: Select all

EnableExplicit

Procedure IsAnagram( String1.s, String2.s )
	Protected *c1.Character, *c2.Character
	Protected len1, len2
	Protected bCharFound
	
	; RemoveSpaces
	String1 = RemoveString( String1, " " )
	String2 = RemoveString( String2, " " )
	
	; Test, if same amount of characters
	len1 = StringByteLength(String1)
	len2 = StringByteLength(String2)
	If len1 <> len2
		ProcedureReturn #False
	EndIf
	
	; ToLowerCase
	String1 = LCase(string1)
	String2 = LCase(String2)
	
	*c1 = @String1
	While *c1\c          ; Loop through String 1
		*c2 = @String2
		bCharFound = #False
		While *c2\c        ; Loop through String 2
			If *c2\c = *c1\c
				MoveMemory( *c2 + SizeOf(Character), *c2, len2 - (*c2 - @String2) )
				bCharFound = #True
				Break
			Else
				*c2 + SizeOf(Character)
			EndIf
		Wend
		If Not bCharFound
			Break
		EndIf
		*c1 + SizeOf(Character)
	Wend
	
	If Not *c1\c
		ProcedureReturn #True
	Else
		ProcedureReturn #False
	EndIf
EndProcedure

Macro TestAnagram( s1, s2 )
	If IsAnagram( s1, s2 )
		Debug "   Anagram: " + s1 + " :: " + s2
	Else
		Debug "No Anagram: " + s1 + " :: " + s2
	EndIf
EndMacro

TestAnagram( "PureBasic", "basic pure" )
TestAnagram( "PureBasic", "basic pure x" )
TestAnagram( "abcd", "xyzv" )
TestAnagram( "PureBasic", "au ei prbsc" )

Nice idea, Danilo

cu, guido

[Danilo]

@Danillo: Your code doesn't clear the global arrays. If you do a test for non-anagrams then all tests are unreliablel afterwards because they are adding to old tallys.

Ooops!

Corrected, thank you!

[RASHAD]

Code: Select all

Procedure.b IsAnagram(SourceString.s,DicoString.s)
  Text$ = DicoString
  Text2$ = SourceString
  If Len(Text$) > Len(Text2$)
     mlen = Len(Text$)
  Else
     mlen = Len(Text2$)
  EndIf
  For i = 1 To mlen
    If Mid(DicoString,i,1) < Chr(65) Or (Mid(DicoString,i,1) > Chr(90) And Mid(DicoString,i,1) < Chr(97)) Or Mid(DicoString,i,1) > Chr(122)
       Text$ = RemoveString(Text$, Mid(DicoString,i,1))
    EndIf
    If Mid(SourceString,i,1) < Chr(65) Or (Mid(SourceString,i,1) > Chr(90) And Mid(SourceString,i,1) < Chr(97)) Or Mid(SourceString,i,1) > Chr(122)
       Text2$ = RemoveString(Text2$, Mid(SourceString,i,1))
    EndIf
  Next
        
  If Len(Text$) <> Len(Text2$)
    ProcedureReturn #False
  EndIf

  For i = 1 To Len(Text$)
   Text2$ = RemoveString(Text2$, Mid(Text$,i,1),0)
   ;Text2$ = RemoveString(Text2$, Mid(Text$,i,1),1)   For Case insensitive remove
  Next

  If Text2$ =""
      ProcedureReturn #True
  Else
      ProcedureReturn #False
  EndIf
EndProcedure


If IsAnagram("PURE BASIC","CUBE SAR!?IP")
  MessageRequester("Oh yeah","Both words are anagram")
Else
  MessageRequester("Nop !","There is no anagram")
EndIf

Edit : Updated

[DarkDragon]

It just counts how often each (unicode-)character is in the strings
and compares the memory.

I also thought about a character histogram.

[EDIT]
Ah sorry, I've just seen 256 as a constant somewhere and mixed it up with your code, but it was luis' ones.

@luis: 256 isn't safe . Danilo did it the correct way.

[EDIT2]
I like the idea with the sorting of the characters inside the string!

[luis]

@Darkdragon: why isn't safe ? Sorry I don't understand.

Not because it doesn't work with unicode I hope (since I wrote it in the post).

Anyway:

Code: Select all

Procedure.i IsAnagram(a$, b$)
 CompilerIf #PB_Compiler_Unicode  
  #anagram_counter_size = 65536   
 CompilerElse
  #anagram_counter_size = 256  
 CompilerEndIf          
 Protected *a.Character, *b.Character, l, i 
 Protected Dim ac(#anagram_counter_size - 1), Dim bc(#anagram_counter_size - 1)
 
 l = Len(a$) : If l <> Len(b$) : ProcedureReturn 0 : EndIf 
 *a = @a$ : *b = @b$ 
 For i = 1 To l     
     ac(*a\c) + 1 : *a + SizeOf(Character)
     bc(*b\c) + 1 : *b + SizeOf(Character)
 Next 
 ProcedureReturn CompareMemory(@ac(), @bc(), #anagram_counter_size * SizeOf(Integer)) 
EndProcedure


a$ = "pure basic"
b$ = "preuabic s"
Debug IsAnagram(a$, b$)

Should work right ? Quite compact too

EDIT: -1 in the Dim

[helpy]

Anagram on Wikipedia:

==> A decimal point = I'm a dot in place

This example shows, that before testing the strings, all none-letter characters (spaces, apostropes, dots, ...) should be removed!

This means that IsAnagram should depend on the alphabet of a language!

cu,
guido