FreeBASIC 連想配列(Ultimate FB HashMap)

目次→フォーラム→FreeBASIC→補足→Ultimate FB HashMap←オリジナル・サイト

連想配列(Ultimate FB HashMap)　左にメニュー・フレームが表示されていない場合は、ここをクリックして下さい

　このページは、Zamaster さんが、掲示板に投稿された「The Ultimate FB HashMap」を日本語化して紹介するものです。
　この HashMap テーブルは極めて適切にスケーリングされます。1項目でも、100万項目追加した状態でも、挿入/削除/検索の時間は同じです。
(inline-asm を使っています。)

注意１：プログラムのパスやファイル名に日本語は使えません。半角英数のみで使います。
注意２：Win64 では使えないので、Win32 で使います。 Win64 でも使える連想配列(GLib Hash Table)が有ります。
注意３：FreeBASIC 1.05 だと使える連想配列に、Dictionary Class があります。

ライブラリとして提供されているコードを使う手順は簡単です。

- 'hashmap2.bi' ヘッダファイルを FreeBasic 登録フォルダのインクルードフォルダ（通常は/incフォルダ）にコピーします。
もしくは、コンパイルするソース・プログラムと同じフォルダに登録します。

　ディクショナリを使うには、下記事例の、★１、★２、★３、★４、を含める必要があります。
#include once "hashmap2.bi"

１．ランダムな文字列でパフォーマンスを検証
２．キー生成での干渉の有無チェック
３．品目マスタと品目オーダを照合
４．英文字の出現頻度を数える

ランダムな文字列でパフォーマンスを検証

　ランダムな文字列を生成して、HashMap の使い方とパフォーマンスの確認を行う事例です。

mainJP.bas

'The Ultimate FB HashMap
'by Zamaster ≫ Feb 23, 2016 8:11
'https://www.freebasic.net/forum/viewtopic.php?p=216439

'table.insert(hash_code(i), i + 1) '索引を生成
'table.clear()                     '索引を消去
'table.retrieve(hash_code(i))      '設定済の索引を取得
'table.remove(hash_code(i))        '設定済の索引を削除
'table.exists(hash_code(i))        '索引の有無をチェック
'function exists(_key as _KEYTYPE_) as bool     '索引の有無をチェック


#Include "hashmap2.bi"                      '★１★★★★★★★★★★★
'#define TEST_HASHES 100000
#define TEST_HASHES 100

dsm_HashMap_define(ZString, Integer)       '★２★★★★★★★★★★★

Using dsm                                  '★３★★★★★★★★★★★

Dim As HashMap(ZString, Integer) table     '★４★★★★★★★★★★★
Dim As Integer i


Function generateGarbageString() As String 'ランダムの文字列を生成
    Dim As Integer rand_char
    Dim As Integer length
    Dim As Integer i
    Dim As Integer capitalize
    Dim As String rand_string
    rand_string = ""
    length = Int(Rnd * 64) + 3
    capitalize = 1
    For i = 0 To length
        If Int(Rnd * 5) = 0 AndAlso capitalize = 0 Then
            rand_string += " "
            capitalize = 1
        Else
            rand_char = Int(Rnd * (Asc("z") - Asc("a"))) + Asc("a")
            If capitalize = 1 Then
                rand_string += UCase(Chr(rand_char))
            Else
                rand_string += Chr(rand_char)
            End If
            capitalize = 0
        End If
    Next i
    Return rand_string
End Function

Print "配列を準備"
ReDim As String hash_code(0 To TEST_HASHES-1)

Print
Print "ランダムな文字列 100 件を配列に登録して索引を付けます。何かキー入力で実行します。"
Sleep

For i = 0 To TEST_HASHES-1
    hash_code(i) = generateGarbageString()
    table.insert(hash_code(i), i + 1)
    Print i + 1, hash_code(i)
Next i
'Print "inserted all!"
Print "ランダム文字列の配列のための索引テーブル完了!"
Print

table.clear()
'Print "cleared all!"
Print "索引部分をすべて消去!"
Print

Print "作成済の配列に再度索引を付ける"
Sleep
For i = 0 To TEST_HASHES-1
    table.insert(hash_code(i), i + 1)
    Print i + 1, hash_code(i)
Next i
'Print "inserted all!"
Print "全て挿入済!"
Print
Print "設定済の索引を検索してその数値を合計する ((1+100)*100/2=5050)"
Sleep

Dim As Integer x
x = 0
For i = 0 To TEST_HASHES-1
    x += table.retrieve(hash_code(i))
Next i
Print x
'Print "sought all!"
Print "全て求めた!"
Print
Print "テーブルから半分消去"
Sleep

For i = 0 To TEST_HASHES*0.5-1
    If table.remove(hash_code(i)) Then
        Print "failure! : "; i + 1;
        Print hash_code(i)
        Sleep
    Else
        Print i + 1
    End If
Next i
'Print "removed half!"
Print "テーブルから半分消去済！"
Print
Print "テーブルに、半分挿入"
Sleep

For i = 0 To TEST_HASHES*0.5-1
    table.insert(hash_code(i), i + 1)
    Print i + 1, hash_code(i)
Next i
'Print "inserted half!"
Print "テーブルに、半分挿入済！"
Print
Print "テーブルから全て消去"
Sleep

For i = 0 To TEST_HASHES-1
    If table.remove(hash_code(i)) Then
        Print "failure! : "; i + 1;
        Print hash_code(i)
        Sleep
    Else
        Print i + 1
    End If
Next i
'Print "removed all!"
Print "テーブルから全て消去済！"
Sleep
End

ページの頭に戻る

キー生成での干渉の有無チェック

　HashMap で生成するキーの衝突 (collision) を検証するプログラムです。

UsageTest3JP.bas

'https://www.freebasic.net/forum/viewtopic.php?f=7&t=11538&p=273317#p273317
'by srvaldez ≫ Jun 19, 2020 12:04


#Include "hashmap2.bi"                            '★１★★★★★★★★★★★

dsm_HashMap_define(ZString, Integer)             '★２★★★★★★★★★★★

Using dsm                                        '★３★★★★★★★★★★★

Dim As HashMap(ZString, Integer) ArrayItemID     '★４★★★★★★★★★★★
Dim Shared ItemID As String
Dim Shared As Integer Counter, i, j, k, l
Dim BoolVar As Boolean
Dim As Single t1,t2


t1=Timer
Counter = 0
For i = Asc("A") To Asc("Z")
   Print i;
   For j = Asc("A") To Asc("Z")
      For k = Asc("A") To Asc("Z")
         For l = Asc("A") To Asc("Z")
            ItemID =  Chr(i) + Chr(j) + Chr(k) + Chr(l)

            BoolVar = ArrayItemID.exists(ItemID)' ItemIDの存在を確認

            If BoolVar = FALSE Then      '***********
               Counter += 1
               ArrayItemID.insert( ItemID, Counter )     '★５★★★★★★★★★★★
            Else
               'キーの重複が発生したら表示する
               Print
               Print Counter, ItemID
               Sleep
            End If
         Next l
      Next k
   Next j
Next i

t2=Timer

Print
Print
Print "終了しました。 ItemID = "; ItemID; "      Counter = 26^4(456,976) = "; Counter
Print
Print "所要秒数 = ";t2 - t1
Sleep

ページの頭に戻る

品目マスタと品目オーダを照合

　品目マスタ(15,000件)と品目オーダ(50,000件)を照合して、品目別の受注数量・金額・重量を集計する事例です。
　私のパソコン環境で、1秒以下で処理が完了しました。
　(このプログラムは、Excelマクロで作成して利用していたものを FreeBASIC に移植したものです。)

サンプルデータを作成するための地域ファイル
region.txt

北海道
青森県
岩手県
宮城県
秋田県
山形県
福島県
茨城県
栃木県
群馬県
埼玉県
千葉県
東京都
神奈川県
新潟県
富山県
石川県
福井県
山梨県
長野県
岐阜県
静岡県
愛知県
三重県
滋賀県
京都府
大阪府
兵庫県
奈良県
和歌山県
鳥取県
島根県
岡山県
広島県
山口県
徳島県
香川県
愛媛県
高知県
福岡県
佐賀県
長崎県
熊本県
大分県
宮崎県
鹿児島県
沖縄県

ページの頭に戻る

サンプルデータ(品目マスタと品目オーダ)を作成するプログラム
PrepareTestData00Jp.bas

'テスト・データを生成
'Prepare test Data

Dim Shared Counter As Integer
Dim Shared ItemID As String
Dim STARTT As Long
Dim ENDTIME As Long
Dim Minut As Integer


Sub FabricateData()

   Dim RegionArray() As String
   Dim file_name As String
   Dim file_num As Integer
   Dim FirstDigit As Integer
   Dim SecondDigit As Integer
   Dim ThirdDigit As Integer
   Dim CharacterString As String
   Dim Regions As Integer

   'Fabricate ItemMaster

   file_name = "region.txt"
   file_num = FreeFile( )                 '' 有効なファイル番号を検索します
   Regions = 0

   '' ファイルを開きます。そして、ファイル番号をそれに結び付けます。エラーが有れば、抜けます。
   If( Open( file_name For Input As #file_num ) ) Then
      Print "ERROR: 開こうとしたファイル名 " ; file_name
      Sleep
      End -1
   End If

   Do Until EOF( file_num )               '' ファイルの端に達するまで、繰り返します。
      Regions = Regions + 1
      ReDim Preserve RegionArray(Regions)
      Line Input #file_num, RegionArray(Regions)           '' テキストの行を読みます。
      Print RegionArray(Regions)                           '' 画面にそれを出力します。
   Loop

   Close #file_num                        '' ファイル番号を通したファイルを閉じます。

   Open "ItemMaster.csv"  For Output As #1

   Counter = 0

   For FirstDigit = 1 To 26
      For SecondDigit = 1 To 26
         For ThirdDigit = 1 To 26
            CharacterString = ""
            Counter = Counter + 1
            If Counter > 15000 Then Exit For
            ItemID = Chr(64 + FirstDigit) & Chr(64 + SecondDigit) & Chr(64 + ThirdDigit) 'ItemID
            CharacterString = ItemID
            CharacterString = CharacterString & ",""" & RegionArray(Int(Rnd() * Regions) + 1)
            CharacterString = CharacterString & """," &  (Int(Rnd() * 1000) + 1) * 10    'price
            CharacterString = CharacterString & "," &  (Int(Rnd() * 100) + 1) * 10       'weight
            'Print CharacterString
            'Sleep
            Print #1, CharacterString
         Next ThirdDigit
      Next SecondDigit
   Next FirstDigit

   Close #1

   'Fabricate OrderList

   Open "OrderList.csv"  For Output As #1

   For Counter = 1 To 50000
      ItemID = Chr(64 + Int(Rnd() * 26) + 1) & Chr(64 + Int(Rnd() * 26) + 1) & Chr(64 + Int(Rnd() * 26) + 1)
      CharacterString = ItemID & "," & Int(Rnd() * 100) + 1               'quantity
      Print #1, CharacterString
   Next Counter

   Close #1

End Sub


STARTT=Val(Left(Time,2))*3600+Val(Mid(Time,4,2))*60+Val(Right(Time,2))

Randomize

FabricateData()

ENDTIME = Val(Left(Time,2))*3600+Val(Mid(Time,4,2))*60+Val(Right(Time,2))
Minut=(ENDTIME-STARTT)\60
Print
'Print Using "Processing time was ## minutes ## seconds."; Minut; (ENDTIME-STARTT)-Minut*60
Print Using "処理時間は ## 分 ## 秒"; Minut; (ENDTIME-STARTT)-Minut*60
Print "*******************************************************"
'Print "Please enter any key to exit."
Print "終了するために何かキー入力して下さい。"
Sleep

ページの頭に戻る

OrderSorting07JpUdt.bas

'品目マスタと品目オーダを照合して品目別受注量を集計
'Order sorting

'The Ultimate FB HashMap
'by Zamaster ≫ Feb 23, 2016 8:11
'https://www.freebasic.net/forum/viewtopic.php?p=216439

'table.insert(hash_code(i), i + 1) '索引を生成
'table.clear()                     '索引を消去
'table.retrieve(hash_code(i))      '設定済の索引を取得。未登録のキーを検索すると異常終了する
'table.remove(hash_code(i))
'table.exists(hash_code(i))        '索引の有無チェック
'function exists(_key as _KEYTYPE_) as bool         '索引の有無チェック


#Include "hashmap2.bi"                                   '★１★★★★★★★★★★★

dsm_HashMap_define(ZString, Integer)                    '★２★★★★★★★★★★★

Using dsm                                               '★３★★★★★★★★★★★

Dim As HashMap(ZString, Integer) MasterItemID           '★４★★★★★★★★★★★
Dim As HashMap(ZString, Integer) OrderItemID            '★４★★★★★★★★★★★

Dim STARTT As Long
Dim ENDTIME As Long
Dim Minut As Integer
Dim Shared ItemID As String
Dim Shared Region As String
Dim Shared Price As String
Dim Shared Weight As String
Dim Shared Counter As Integer
Dim i As Integer
Dim BoolVar As Boolean
Dim QuantityString As String
Dim Amount As String
Dim Dimension As Integer
Dim cellString As String

Dim file_name As String
Dim file_num As Integer
Dim CharacterString As String
Dim Regions As Integer
Dim ItemMasterNo As Integer
Dim IntegratedNo As Integer
Dim Orders As Integer

Dim Shared ItemMasterArray(20000,3) As String 'Region, price, weight
Dim Shared IntegratedOrderArray(20000,5) As String 'Region, ItemID, Quantity, Amount, Weight
Dim Shared SortArray(20000) As String

'****************************************************************
'****************************************************************

'★★★多次元配列を複数列を使ってソート★★★
'How to sort datasheet (x-dim array) by a few columns (at once in 1 loop) ?
'by badidea ≫ Dec 15, 2019 21:54
'https://www.freebasic.net/forum/viewtopic.php?f=3&t=27993&start=30#p266914

'by fxm ≫ Jun 25, 2020 6:49
'https://www.freebasic.net/forum/viewtopic.php?f=3&p=273475&sid=547977eb5d3cc9cf3e6ee7323616cff3#p273475

#Include "crt/stdlib.bi"
#Include "string.bi"

'------------------------------- class: row_type -------------------------------

Type row_type
   Dim As String col(Any)
   Declare Operator Cast () As String
End Type

Operator row_type.cast () As String
   Dim As String tempStr
   For i As Integer = 1 To UBound(col)
      If i = 1 Then tempStr &= col(i) Else tempStr &= !"\t" & col(i)
   Next
   Return tempStr
End Operator

'------------------------------ class: sort_type -------------------------------

Type sort_type
   Dim As Short column
   Dim As Short direction
   Declare Constructor()
   Declare Constructor(column As Short, direction As Short)
End Type

'a stupid constructor
Constructor sort_type()
   this.column = 0
   this.direction = 0
End Constructor

'another stupid constructor
Constructor sort_type(column As Short, direction As Short)
   this.column = column
   this.direction = direction
End Constructor

'------------------------------ class: data_type -------------------------------

Type data_type
   Static As sort_type sortOrder(1 To 3)
   Dim As Integer numRows, numCols
   Dim As row_type row(Any)
   Declare Constructor(numRows As Integer, numPivotMS As Integer)
   Declare Destructor()
   Declare Sub copyTo(dst As data_type)
   Declare Sub sort(sort1st As sort_type, sort2nd As sort_type, sort3rd As sort_type)
   Declare Static Function qSortCallback Cdecl(pRow1 As row_type Ptr, pRow2 As row_type Ptr) As Long
End Type

Dim As sort_type data_type.sortOrder(1 To 3)

Constructor data_type(numRows As Integer, numCols As Integer)
   ReDim row(numRows)
   this.numCols = numCols
   For iRow As Integer = 1 To numRows
      ReDim (row(iRow).col)(numCols) 'weird syntax, compiler wants the extra ( )
   Next
End Constructor

Destructor data_type()
   For iRow As Integer = 1 To numRows
      Erase row(iRow).col
   Next
   Erase row
End Destructor

Sub data_type.sort(sort1st As sort_type, sort2nd As sort_type, sort3rd As sort_type)
   'disable invalid sort filters
   sortOrder(1) = IIf(sort1st.column < 1 Or sort1st.column >= numCols, sort_type(0,0), sort1st)
   sortOrder(2) = IIf(sort2nd.column < 1 Or sort2nd.column >= numCols, sort_type(0,0), sort2nd)
   sortOrder(3) = IIf(sort3rd.column < 1 Or sort3rd.column >= numCols, sort_type(0,0), sort3rd)
   qsort(@row(1), UBound(row), SizeOf(row_type), CPtr(Any Ptr, @qSortCallback))
End Sub

Function data_type.qSortCallback Cdecl(pRow1 As row_type Ptr, pRow2 As row_type Ptr) As Long
   For i As Integer = 1 To 3
      With sortOrder(i)
         Select Case .direction
         Case +1
            If pRow1->col(.column) < pRow2->col(.column) Then Return -1
            If pRow1->col(.column) > pRow2->col(.column) Then Return +1
         Case -1
            If pRow1->col(.column) > pRow2->col(.column) Then Return -1
            If pRow1->col(.column) < pRow2->col(.column) Then Return +1
         Case Else
            'skip, including direction = 0
         End Select
      End With
   Next
   Return 0
End Function


'****************************************************************
'****************************************************************
   'Print "Read ""ItemMaster.csv"" and store each line in ItemMasterArray, indexing ItemID."
   Print """ItemMaster.csv"" を読み込んで ItemMasterArray, indexing ItemID. に登録"
'****************************************************************
   Print

   file_name = "ItemMaster.csv"
   file_num = FreeFile( )                 '' 有効なファイル番号を検索します

   '' ファイルを開きます。そして、ファイル番号をそれに結び付けます。エラーが有れば、抜けます。
   If( Open( file_name For Input As #file_num ) ) Then
      Print "ERROR: 開こうとしたファイル名 " ; file_name
      Sleep
      End -1
   End If

   Counter = 0

   Do Until Eof( file_num )               '' ファイルの端に達するまで、繰り返します。
      ItemID ="": Region ="": Price ="" : Weight =""

      Line Input #file_num, CharacterString           '' テキストの行を読みます。

      ItemID = Left(CharacterString,3)
      Region = Mid(CharacterString,6,InStrRev(CharacterString,"""")-6)
      Price  = Mid(CharacterString,InStrRev(CharacterString,"""")+2,InStrRev(CharacterString,",")-InStrRev(CharacterString,"""")-2)
      Weight = Right(CharacterString,Len(CharacterString)-InStrRev(CharacterString,","))

      BoolVar = MasterItemID.exists(ItemID)              '★６★★★★★★★★★★★

      If BoolVar = FALSE Then
         Counter = Counter + 1
         MasterItemID.insert( ItemID, Counter )          '★５★★★★★★★★★★★

         ItemMasterArray(Counter,1) = Region
         ItemMasterArray(Counter,2) = Price
         ItemMasterArray(Counter,3) = Weight
      Else
         Print BoolVar
         Print CharacterString                           '' キー重複を画面に出力します。
         Print ItemID , Region , Price ,  Weight
         Print Counter
         Sleep
      End If

   Loop
   'Print "Numbers of Item Master = ";Counter
   Print "品目マスタの件数 = ";Counter
   Print
   Print "品目マスタの最後のデータの内容 : ";CharacterString  ' 画面に最終行を出力します。
   Print ItemID , Region , Price ,  Weight
   Print

   Close #file_num                        '' ファイル番号を通したファイルを閉じます。

'****************************************************************
'****************************************************************
   'Print "Read ""OrderList.csv"" and compare it with ItemMasterArray to aggregate price and weight by item and region."
   Print """OrderList.csv"" を読み込み、ItemMasterArray と照合して、品目毎に数量・金額・重量を集計します。"
'****************************************************************
   Print

   Open "OrderItemError.csv"  For Output As #1

   file_name = "OrderList.csv"
   file_num = FreeFile( )                 '' 有効なファイル番号を検索します

   '' ファイルを開きます。そして、ファイル番号をそれに結び付けます。エラーが有れば、抜けます。
   If( Open( file_name For Input As #file_num ) ) Then
      Print "ERROR: 開こうとしたファイル名 " ; file_name
      Sleep
      End -1
   End If

   Counter = 0
   Orders  = 0

   STARTT=Val(Left(Time,2))*3600+Val(Mid(Time,4,2))*60+Val(Right(Time,2))

   Do Until Eof( file_num )               '' ファイルの端に達するまで、繰り返します。
      CharacterString = "" : ItemID = "" : QuantityString = ""

      Line Input #file_num, CharacterString           '' テキストの行を読みます。
      Orders  = Orders + 1
      ItemID = Left(CharacterString,3)
      QuantityString = Right(CharacterString,Len(CharacterString)-InStrRev(CharacterString,","))

      BoolVar = MasterItemID.exists(ItemID)

      If BoolVar = FALSE Then      '★６★★★★★★★★★★★
         'エラー出力
         Print #1, CharacterString
      Else
         ItemMasterNo = MasterItemID.retrieve(ItemID)

         'ItemMasterArray(20000,3)      'Region, price, weight
         'IntegratedOrderArray(20000,5) 'Region, ItemID, Quantity, Amount, Weight

         Region = ItemMasterArray(ItemMasterNo,1)
         Amount = Str(Val(QuantityString)*Val(ItemMasterArray(ItemMasterNo,2)))
         Weight = Str(Val(QuantityString)*Val(ItemMasterArray(ItemMasterNo,3)))

         BoolVar = OrderItemID.exists(ItemID)

         If BoolVar = FALSE Then                           '★６★★★★★★★★★★★
            Counter = Counter + 1
            OrderItemID.insert( ItemID, Counter )          '★５★★★★★★★★★★★

            IntegratedOrderArray(Counter,1) = Region
            IntegratedOrderArray(Counter,2) = ItemID
            IntegratedOrderArray(Counter,3) = QuantityString
            IntegratedOrderArray(Counter,4) = Amount
            IntegratedOrderArray(Counter,5) = Weight
            'Print Counter,Region,ItemID,QuantityString,Amount,Weight
            'sleep

         Else
            IntegratedNo = OrderItemID.retrieve(ItemID)

            IntegratedOrderArray(IntegratedNo,3) = Str(Val(IntegratedOrderArray(IntegratedNo,3))+Val(QuantityString))
            IntegratedOrderArray(IntegratedNo,4) = Str(Val(IntegratedOrderArray(IntegratedNo,4))+Val(Amount))
            IntegratedOrderArray(IntegratedNo,5) = Str(Val(IntegratedOrderArray(IntegratedNo,5))+Val(Weight))
            'Print IntegratedNo,ItemID,QuantityString,Amount,Weight
            'sleep

         End If
      End If

   Loop
   'Print "Number of orders in the list : ";Orders
   Print "リスト中のオーダ件数 : ";Orders

   Print
   ENDTIME = Val(Left(Time,2))*3600+Val(Mid(Time,4,2))*60+Val(Right(Time,2))
   Minut=(ENDTIME-STARTT)\60
   'Print Using "processing time: ## minutes ## seconds"; Minut; (ENDTIME-STARTT)-Minut*60
   Print Using "処理時間: ## 分 ## 秒"; Minut; (ENDTIME-STARTT)-Minut*60

   Print

   Close #1
   Close #file_num                        '' ファイル番号を通したファイルを閉じます。



'****************************************************************
'****************************************************************
   'Print "Sort the totaled results by Region and ItemID."
   Print "集計結果を、地域順・品目コード順に並び替えます。"
'****************************************************************
   Print


'-------------------------------- main program ---------------------------------

Dim As Integer numRows = Counter, numCols = 5

Var myData = data_type(numRows, numCols)

For iRow As Integer = 1 To Counter
   With myData.row(iRow)
      For iCol As Integer = 1 To UBound(.col)
         .col(iCol) = IntegratedOrderArray(iRow,iCol)
      Next
   End With
Next iRow

myData.sort(sort_type(1, +1), sort_type(2, +1), sort_type(0, 0))

For iRow As Integer = 1 To Counter
   With myData.row(iRow)
      For iCol As Integer = 1 To UBound(.col)
         IntegratedOrderArray(iRow,iCol) = .col(iCol)
      Next
   End With
Next iRow


'****************************************************************
'****************************************************************
   'Print "Out put the sorted results to ""OrderSorting.csv"""
   Print "集計結果を ""OrderSorting.csv"" として出力します。"
'****************************************************************
   Print

   'IntegratedOrderArray(20000,5) 'Region, ItemID, Quantity, Amount, Weight
   Open "OrderSorting.csv"  For Output As #1
      For i = 1 To Counter
         CharacterString = ""
         For Dimension =1 To 5
            cellString = IntegratedOrderArray(i,Dimension)
            If Dimension = 1 Then
               cellString = """" & cellString & """"
            EndIf
            If Dimension > 1 Then
               cellString = "," & cellString
            EndIf
            CharacterString = CharacterString & cellString
         Next Dimension

         Print #1, CharacterString

      Next i
   Close #1

'****************************************************************
'****************************************************************
   'Print "Output of the sorted order aggregate has been completed."
   Print "集計結果のリスト出力が完了しました。"
   Print "*******************************************************"
   'Print "Please enter any key to exit."
   Print "何かキー入力すると終了します。"
Sleep

ページの頭に戻る

英文字の出現頻度を数える

　次の使用例は、英文のテキスト・ファイル中の文字と出現頻度を調べるものです。

　探偵小説シャーロック・ホームズシリーズの「踊る人形」では、換字暗号が使われています。
　小説の中で、シャーロック・ホームズは、英文中の文字の出現頻度から、「踊る人形」の暗号を解読します。

　「踊る人形」の解読方法
http://www.comm.tcu.ac.jp/~math/hnakai/infomath/sherlockholmes/dance_decording.html
　頻度分析 (暗号)
https://ja.wikipedia.org/wiki/%E9%A0%BB%E5%BA%A6%E5%88%86%E6%9E%90_(%E6%9A%97%E5%8F%B7)

TheAdventureOfTheDancingMen.txt ←文字列抽出に使ったファイル

CountTheNoOfOccurrencesOfCharacters2win9.bas

'文字の出現頻度を数える

'The Ultimate FB HashMap
'by Zamaster ≫ Feb 23, 2016 8:11
'https://www.freebasic.net/forum/viewtopic.php?p=216439

'table.insert(hash_code(i), i + 1) '索引を生成
'table.clear()                     '索引を消去
'table.retrieve(hash_code(i))      '設定済の索引を取得。未登録のキーを検索すると異常終了する
'table.remove(hash_code(i))
'table.exists(hash_code(i))        '索引の有無チェック
'function exists(_key as _KEYTYPE_) as bool         '索引の有無チェック


/'
	******************************************
	文字の出現頻度を数える
	******************************************

	このコードは、The Ultimate FB HashMap の使用例を示しています。
'/


'****************************************************************
'' レコードの配列を文字の出現頻度順にソートする
'****************************************************************

'★★★文字列ソート★★★
Sub StringSort _
    (Array(Any) As String , _
     ByVal StartLine As Integer , _
     ByVal EndLine As Integer)

 Dim CenterLine As Integer                       'CenterLine を格納する変数
 Dim Reference As String                         'Referenceを 格納する変数
 Dim Position As Integer                         'Position
 Dim i As Integer                                'ループカウンタ

    If StartLine >= EndLine Then Exit Sub        '終了番号が開始番号以下の場合、手続きを抜ける
    CenterLine = (StartLine + EndLine) \ 2       'CenterLineを求める
    Reference = Array(CenterLine)                '中央の値をReferenceとする
    Array(CenterLine) = Array(StartLine)         '中央の要素に開始番号の値を格納
    Position = StartLine                         'Positionを開始番号と同じにする
    For i = (StartLine + 1) To EndLine Step 1    '開始番号の次の要素から終了番号までループ
        If Array(i) < Reference  Then            '値がReferenceより小さい場合
            Position = Position + 1              'Positionをインクリメント
            Swap Array(Position) , Array(i)
        End If
    Next
    Array(StartLine) = Array(Position)           'Array(Position) を開始番号の値にする
    Array(Position) = Reference                  'Referenceを Array(Position) に格納
    StringSort(Array(), StartLine, Position - 1) '分割された配列をクイックソート(再帰)
    StringSort(Array(), Position + 1, EndLine)   '分割された配列をクイックソート(再帰)

End Sub

'****************************************************************

/'
	★★★★★★★★★★★★
	辞書の使用例
'/

'' 文字と頻度の辞書を作成する
   '★CharacterIndexを作成★

   Dim FullPass As String  '対象ファイルのフルパス

   '調べたい文字列を含むファイルを入力する
'********************* Window9 のファイルを開くダイアログを使う *********************
   #Include "window9.bi"
   Var ddd = OpenFileRequester("Specify English text file",ExePath,"Text File(*.txt;*.csv;*.htm*)"_
   +Chr(0)+"*.txt;*.csv;*.htm*"+Chr(0)+"All File(*.*)"+Chr(0)+"*.*"+Chr(0))

   FullPass = Str(ddd)

   '' ソート用の配列を作る
   Dim CountsCharacter(100) As String  '99999 a ：5桁数字、空白、文字、計7文字
   Dim Filehandle As Integer
   Dim TotalCountOfCharacters As Integer
   Dim Counter As Integer
   Dim NumberOfCharacterTypes As Integer
   Dim Number As Integer
   Dim NumberString As String

Counter = 0

   #Include "hashmap2.bi"                                  '★１★★★★★★★★★★★

   dsm_HashMap_define(ZString, Integer)                    '★２★★★★★★★★★★★

   Using dsm                                               '★３★★★★★★★★★★★

   'レコードを処理するための辞書実装
   Dim As HashMap(ZString, Integer) CharacterDictionary    '★４★★★★★★★★★★★
   Dim BoolVar As Boolean
   Dim DictionaryNo As Integer
   Dim CharacterSymbol As String
   Dim CountsOfLine As Integer
   Dim CountsOfCharacter As Integer
   Dim StringVariable As String
   Dim Position As Integer

   If FullPass<>"" Then
      Filehandle = FreeFile( )                 '' 有効なファイル番号を検索します

      '' ファイルを開きます。そして、ファイル番号をそれに結び付けます。エラーが有れば、抜けます。
      If( Open( FullPass For Input As #Filehandle ) ) Then
         Print "ERROR: 開こうとしたファイル名 " ; FullPass
         Sleep
         End -1
      End If

      ' テキストファイルの内容読み込み処理
      CountsOfLine = 0
      TotalCountOfCharacters = 0

      Filehandle = FreeFile
      Open FullPass For Input As #Filehandle
      'テキストファイルのオープン

      If Lof(Filehandle) > 0 Then
         Do Until EOF(Filehandle )

            Line Input #Filehandle, StringVariable
            '1行読み込み
            StringVariable = Trim(StringVariable)
            CountsOfLine = Len(StringVariable)
            TotalCountOfCharacters = TotalCountOfCharacters + CountsOfLine

            If CountsOfLine >0 Then
               ?
               ? "行の文字列 = " , StringVariable
               ? "行の文字数 = " , CountsOfLine
               ? "読み込んだ文字数 = ", TotalCountOfCharacters
               ?
               For Position = 1 To CountsOfLine
                  CharacterSymbol = Mid(StringVariable, Position, 1)
                  If Trim(CharacterSymbol) <> "" Then
                     '' 'exists' 関数を使ってキーが存在するかどうかを確認します。

                     BoolVar = CharacterDictionary.exists(CharacterSymbol)

                     If BoolVar = FALSE Then                           '★６★★★★★★★★★★★
                       ' この文字は辞書に登録されていません。辞書に追加します。
                       Counter =Counter +1
                        '? Counter ;
                        '? CharacterSymbol ;
                        CharacterDictionary.insert( CharacterSymbol, Counter )          '★５★★★★★★★★★★★
                        'Dim CountsCharacter(100) As String  '99999 a ：5桁数字、空白、文字、計7文字

                        CountsCharacter(Counter) = "    1 " & CharacterSymbol
                        'Print Counter,CharacterSymbol
                        'sleep

                     Else
                        '既存の場合は文字の出現頻度を追加します

                        DictionaryNo = CharacterDictionary.retrieve(CharacterSymbol)
                        Number = Val(Trim(Left(CountsCharacter(DictionaryNo),5)))
                        Number = Number + 1
                        '? CharacterSymbol;
                        '? Number;
                        '? " ";
                        NumberString = Str(Number)
                        NumberString = Space(5-Len(NumberString)) & NumberString
                        CountsCharacter(DictionaryNo) = NumberString & Right(CountsCharacter(DictionaryNo),2)
                        'Print DictionaryNo,CharacterSymbol,Number
                        'sleep

                     End If
                  End If
               Next Position
            End If
         Loop
      Else
              GoTo HandleErrors
      End If

      Close #Filehandle
      'ファイル番号を通したファイルを閉じます。

   Else
      Print "メッセージ","ファイルが選択されませんでした！"
      Sleep
      End
   EndIf


'配列の出現頻度を更新する
NumberOfCharacterTypes = Counter

?
? "入力を終了しました。何かキー入力で継続します。"
?
Sleep()


'' レコードの配列をソートする
StringSort(CountsCharacter(),1,Counter)

''文字の出現頻度順に出現数と文字を表示します
For Counter = 0 To NumberOfCharacterTypes
  ? CountsCharacter(Counter)
Next

? "入力ファイルの総文字数 = " & TotalCountOfCharacters
?
? "文字の出現頻度順に文字と出現数を表示しました。何かキー入力でプログラムを終了します。"
Sleep()

End

HandleErrors:
Print "指定ファイルが有りません。"
Sleep

ページの頭に戻る

hashmap2.bi

　FreeBASIC の仕様変更に合わせて、「bool」を「__bool」に変更して、hashmap.bi → hashmap2.bi としています。
paul doe さんと、MrSwiss さんに教えていただきました。

'The Ultimate FB HashMap
'by Zamaster ≫ Feb 23, 2016 8:11
'https://www.freebasic.net/forum/viewtopic.php?p=216439


#ifndef HASHMAP_BI
#define HASHMAP_BI

'from dsm\dsmstd.bi
namespace dsm

    enum __bool
        false = 0
        true = 1
    end enum
    type char as ubyte
    #define NULL 0
    type size_t as ulong

end namespace

#define HASHMAP_CONTIGUOUS_BLOCK_N 4
#define HASHMAP_INITIAL_ROW_N 8
#define HASHMAP_SPLIT_RATIO 0.8
#define HASHMAP_COMPACT_RATIO 0.2

namespace dsm
    #macro HASHMAP_DELETION_LOGIC()
        for j = i to start - 1
            cur_row->slots(j) = cur_row->slots(j + 1)
        next j
        cur_row->size -= 1
        if cur_row->size = 0 then
            if last_row then
                last_row->next_block = cur_row->next_block
                deallocate(cur_row)
            else
                if cur_row->next_block then
                    *(cur_row) = *(cur_row->next_block)
                end if
            end if
        end if
        used_size -= 1
        if (cdbl(used_size) / (capacity * HASHMAP_CONTIGUOUS_BLOCK_N)) < _
            HASHMAP_COMPACT_RATIO then down_split_entry()
        return false
    #endmacro
    ' -------------------------- LONG ----------------------------
    #macro HASHMAP_long_STORAGE_DATA()
        key as long
    #endmacro
    #macro HASHMAP_long_DESTRUCT_LOGIC()
        ''
    #endmacro
    #macro HASHMAP_long_INSERTION_LOGIC()
        .key = _key
    #endmacro
    #macro HASHMAP_long_DELETION_LOGIC()
        if _key = cur_row->slots(i).key then
            HASHMAP_DELETION_LOGIC()
        end if
    #endmacro
    #macro HASHMAP_long_EXISTS_LOGIC()
        if _key = cur_row->slots(i).key then return true
    #endmacro
    #macro HASHMAP_long_RETRIEVE_LOGIC()
        if _key = cur_row->slots(i).key then
            _item = cur_row->slots(i).data_
            return true
        end if
    #endmacro
    #macro HASHMAP_long_RETRIEVE_R_LOGIC()
        if _key = cur_row->slots(i).key then
            return cur_row->slots(i).data_
        end if
    #endmacro
    #macro HASHMAP_long_CALC_NEW_POS(_KEYTYPE_, _INDEX_)
        new_pos = hash_##_KEYTYPE_(this, cur_row->slots(_INDEX_).key)
    #endmacro
    #macro HASHMAP_DECLARE_HASH_WRAP_long(_KEYTYPE_, _TYPENAME_)
    function hash_wrap_long naked cdecl _
    ( _
        byref _table as HashMap_##_KEYTYPE_##_TYPENAME_, _
        _key as long _
    ) as size_t
    #endmacro
    #macro HASHMAP_DEFINE_HASH_WRAP_long(_KEYTYPE_, _TYPENAME_)
    function HashMap_##_KEYTYPE_##_TYPENAME_.hash_wrap_long naked cdecl _
    ( _
        byref _table as HashMap_##_KEYTYPE_##_TYPENAME_, _
        _key as long _
    ) as size_t
        asm
        #ifdef __FB_64BIT__
                mov     rcx,                    &h890390f1daf308c
                mov     rax,                    qword ptr [rsp+16]
                shr     qword ptr [rsp+16],     32
                xor     rax,                    qword ptr [rsp+16]
                mul     rcx
        #ifndef HASHMAP_FAST
                mov     qword ptr [rsp+16],     rax
                shr     qword ptr [rsp+16],     32
                xor     rax,                    qword ptr [rsp+8]
                mul     rcx
        #endif
                mov     qword ptr [rsp+16],     rax
                shr     qword ptr [rsp+16],     32
                xor     rax,                    qword ptr [rsp+16]
                mov     rcx,                    qword ptr [rsp+8]
                mov     rdx,                    rax
                and     rax,                    qword ptr [rcx+40]
                cmp     rax,                    qword ptr [rcx+8]
                jl      dsm_hashmap_hashw_long_upperlevel_64
                ret
            dsm_hashmap_hashw_long_upperlevel_64:
                and     rdx,                    qword ptr [rcx+48]
                mov     rax,                    rdx
                ret
        #else
                mov     ecx,                    &h45D9F3B
                mov     eax,                    dword ptr [esp+8]
                shr     dword ptr [esp+8],      16
                xor     eax,                    dword ptr [esp+8]
                mul     ecx
        #ifndef HASHMAP_FAST
                mov     dword ptr [esp+8],      eax
                shr     dword ptr [esp+8],      16
                xor     eax,                    dword ptr [esp+8]
                mul     ecx
        #endif
                mov     dword ptr [esp+8],      eax
                shr     dword ptr [esp+8],      16
                xor     eax,                    dword ptr [esp+8]
                mov     ecx,                    dword ptr [esp+4]
                mov     edx,                    eax
                and     eax,                    dword ptr [ecx+20]
                cmp     eax,                    dword ptr [ecx+4]
                jl      dsm_hashmap_hashw_long_upperlevel_32
                ret
            dsm_hashmap_hashw_long_upperlevel_32:
                and     edx,                    dword ptr [ecx+24]
                mov     eax,                    edx
                ret
        #endif
        end asm
    end function
    #endmacro
    #macro HASHMAP_DECLARE_HASH_long(_KEYTYPE_, _TYPENAME_)
    declare function hash_long naked cdecl _
    ( _
        _key as long _
    ) as size_t
    #endmacro
    #macro HASHMAP_DEFINE_HASH_long(_KEYTYPE_, _TYPENAME_)
    function HashMap_##_KEYTYPE_##_TYPENAME_.hash_long naked cdecl _
    ( _
        _key as long _
    ) as size_t
        asm
        #ifdef __FB_64BIT__
                mov     rcx,                    &h890390f1daf308c
                mov     rax,                    qword ptr [rsp+8]
                shr     qword ptr [rsp+8],      32
                xor     rax,                    qword ptr [rsp+8]
                mul     rcx
        #ifndef HASHMAP_FAST
                mov     qword ptr [rsp+8],      rax
                shr     qword ptr [rsp+8],      32
                xor     rax,                    qword ptr [rsp+8]
                mul     rcx
        #endif
                mov     qword ptr [rsp+8],      rax
                shr     qword ptr [rsp+8],      32
                xor     rax,                    qword ptr [rsp+8]
                ret
        #else
                mov     ecx,                    &h45D9F3B
                mov     eax,                    dword ptr [esp+4]
                shr     dword ptr [esp+4],      16
                xor     eax,                    dword ptr [esp+4]
                mul     ecx
        #ifndef HASHMAP_FAST
                mov     dword ptr [esp+4],      eax
                shr     dword ptr [esp+4],      16
                xor     eax,                    dword ptr [esp+4]
                mul     ecx
        #endif
                mov     dword ptr [esp+4],      eax
                shr     dword ptr [esp+4],      16
                xor     eax,                    dword ptr [esp+4]
                ret
        #endif
        end asm
    end function
    #endmacro
    ' -------------------------- ZSTRING ----------------------------
    #define HASHMAP_zstring_BUFFER_N 32
    #macro HASHMAP_zstring_STORAGE_DATA()
        is_contiguous as __bool
        union
            key_internal as zstring * HASHMAP_zstring_BUFFER_N
            key_external as zstring ptr
        end union
    #endmacro
    #macro HASHMAP_zstring_DESTRUCT_LOGIC()
        dim as integer j
        for j = 0 to cur_block->size - 1
            if cur_block->slots(j).is_contiguous = false then
                deallocate(cur_block->slots(j).key_external)
            end if
        next j
    #endmacro
    #macro HASHMAP_zstring_INSERTION_LOGIC()
        dim as size_t key_length = len(_key)
        if key_length < HASHMAP_zstring_BUFFER_N then
            .key_internal = _key
            .is_contiguous = true
        else
            .key_external = allocate(key_length + 1)
            *(.key_external) = _key
            .is_contiguous = false
        end if
    #endmacro
    #macro HASHMAP_zstring_DELETION_LOGIC()
        if cur_row->slots(i).is_contiguous = false then
            if _key = *(cur_row->slots(i).key_external) then
                deallocate(cur_row->slots(i).key_external)
                HASHMAP_DELETION_LOGIC()
            end if
        else
            if _key = cur_row->slots(i).key_internal then
                HASHMAP_DELETION_LOGIC()
            end if
        end if
    #endmacro
    #macro HASHMAP_zstring_EXISTS_LOGIC()
        if cur_row->slots(i).is_contiguous = true then
            if _key = cur_row->slots(i).key_internal then
                return true
            end if
        else
            if _key = *(cur_row->slots(i).key_external) then
                return true
            end if
        end if
    #endmacro
    #macro HASHMAP_zstring_RETRIEVE_LOGIC()
        if cur_row->slots(i).is_contiguous = true then
            if _key = cur_row->slots(i).key_internal then
                _item = cur_row->slots(i).data_
                return true
            end if
        else
            if _key = *(cur_row->slots(i).key_external) then
                _item = cur_row->slots(i).data_
                return true
            end if
        end if
    #endmacro
    #macro HASHMAP_zstring_RETRIEVE_R_LOGIC()
        if cur_row->slots(i).is_contiguous = true then
            if _key = cur_row->slots(i).key_internal then
                return cur_row->slots(i).data_
            end if
        else
            if _key = *(cur_row->slots(i).key_external) then
                return cur_row->slots(i).data_
            end if
        end if
    #endmacro
    #macro HASHMAP_zstring_CALC_NEW_POS(_KEYTYPE_, _INDEX_)
        if cur_row->slots(_INDEX_).is_contiguous = true then
            new_pos = hash_##_KEYTYPE_ _
            ( _
                cur_row->slots(_INDEX_).key_internal _
            )
        else
            new_pos = hash_##_KEYTYPE_ _
            ( _
                *(cur_row->slots(_INDEX_).key_external) _
            )
        end if
    #endmacro
    #macro HASHMAP_DECLARE_HASH_WRAP_zstring(_KEYTYPE_, _TYPENAME_)
    declare function hash_wrap_zstring naked cdecl _
    ( _
        byref _table as HashMap_##_KEYTYPE_##_TYPENAME_, _
        _key as zstring _
    ) as size_t
    #endmacro
    #macro HASHMAP_DEFINE_HASH_WRAP_zstring(_KEYTYPE_, _TYPENAME_)
    function HashMap_##_KEYTYPE_##_TYPENAME_.hash_wrap_zstring naked cdecl _
    ( _
        byref _table as HashMap_##_KEYTYPE_##_TYPENAME_, _
        _key as zstring _
    ) as size_t
        asm
        #ifdef __FB_64BIT__
                push    rbx
                mov     rax,                    14695981039346656037
                mov     rcx,                    1099511628211
                mov     rbx,                    dword ptr [esp+32]
            dsm_hashmap_hashw_zstring_loopstart_64:
                mov     dl,                     byte ptr [rbx]
                or      dl,                     dl
                jz      dsm_hashmap_hashw_zstring_return_64
                xor     al,                     dl
                mul     rcx
                inc     rbx
                jmp     dsm_hashmap_hashw_zstring_loopstart_64
            dsm_hashmap_hashw_zstring_return_64:
                pop     rbx
                mov     rcx,                    qword ptr [rsp+8]
                mov     rdx,                    rax
                and     rax,                    qword ptr [rcx+40]
                cmp     rax,                    qword ptr [rcx+8]
                jl      dsm_hashmap_hashw_zstring_upperlevel_64
                ret
            dsm_hashmap_hashw_zstring_upperlevel_64:
                and     rdx,                    qword ptr [rcx+48]
                mov     rax,                    rdx
                ret
        #else
                push    ebx
                mov     eax,                    2166136261
                mov     ecx,                    16777619
                mov     ebx,                    dword ptr [esp+16]
            dsm_hashmap_hashw_zstring_loopstart_32:
                mov     dl,                     byte ptr [ebx]
                or      dl,                     dl
                jz      dsm_hashmap_hashw_zstring_return_32
                xor     al,                     dl
                mul     ecx
                inc     ebx
                jmp     dsm_hashmap_hashw_zstring_loopstart_32
            dsm_hashmap_hashw_zstring_return_32:
                pop     ebx
                mov     ecx,                    dword ptr [esp+4]
                mov     edx,                    eax
                and     eax,                    dword ptr [ecx+20]
                cmp     eax,                    dword ptr [ecx+4]
                jl      dsm_hashmap_hashw_zstring_upperlevel_32
                ret
            dsm_hashmap_hashw_zstring_upperlevel_32:
                and     edx,                    dword ptr [ecx+24]
                mov     eax,                    edx
                ret
        #endif
        end asm
    end function
    #endmacro
    #macro HASHMAP_DECLARE_HASH_zstring(_KEYTYPE_, _TYPENAME_)
    declare function hash_zstring naked cdecl (_key as zstring) as size_t
    #endmacro
    #macro HASHMAP_DEFINE_HASH_zstring(_KEYTYPE_, _TYPENAME_)
    function HashMap_##_KEYTYPE_##_TYPENAME_.hash_zstring naked cdecl _
    ( _
        _key as zstring _
    ) as size_t
        asm
        #ifdef __FB_64BIT__
                push    rbx
                mov     rax,                    14695981039346656037
                mov     rcx,                    1099511628211
                mov     rbx,                    dword ptr [esp+24]
            dsm_hashmap_hash_zstring_loopstart_64:
                mov     dl,                     byte ptr [rbx]
                or      dl,                     dl
                jz      dsm_hashmap_hash_zstring_return_64
                xor     al,                     dl
                mul     rcx
                inc     rbx
                jmp     dsm_hashmap_hash_zstring_loopstart_64
            dsm_hashmap_hash_zstring_return_64:
                pop     rbx
                ret
        #else
                push    ebx
                mov     eax,                    2166136261
                mov     ecx,                    16777619
                mov     ebx,                    dword ptr [esp+12]
            dsm_hashmap_hash_zstring_loopstart_32:
                mov     dl,                     byte ptr [ebx]
                or      dl,                     dl
                jz      dsm_hashmap_hash_zstring_return_32
                xor     al,                     dl
                mul     ecx
                inc     ebx
                jmp     dsm_hashmap_hash_zstring_loopstart_32
            dsm_hashmap_hash_zstring_return_32:
                pop     ebx
                ret
        #endif
        end asm
    end function
    #endmacro
end namespace

#define HashMap(_KEYTYPE_, _TYPENAME_) HashMap_##_KEYTYPE_##_TYPENAME_

namespace dsm
    type HashMap_Initialization_Object
        public:
            declare constructor(_hashmap_construct as sub(),_
                                _hashmap_destruct as sub())
            declare destructor()
        private:
            as sub() hashmap_destruct
    end type
    constructor HashMap_Initialization_Object(_hashmap_construct as sub(),_
                                              _hashmap_destruct as sub())
        _hashmap_construct()
        hashmap_destruct = _hashmap_destruct
    end constructor
    destructor HashMap_Initialization_Object()
        hashmap_destruct()
    end destructor
end namespace

#define HASHMAP_ROWSIZE(_K_, _T_) sizeof(HashMap_##_K_##_T_##_Row)

#macro dsm_HashMap_define(_KEYTYPE_, _TYPENAME_)

#ifndef HASHMAP_INITIALIZED_##_KEYTYPE_##_TYPENAME_
#define HASHMAP_INITIALIZED_##_KEYTYPE_##_TYPENAME_

namespace dsm

    type HashMap_##_KEYTYPE_##_TYPENAME_##_key_pair
        HASHMAP_##_KEYTYPE_##_STORAGE_DATA()
        as _TYPENAME_ data_
    end type
    type HashMap_##_KEYTYPE_##_TYPENAME_##_Row
        as size_t size
        as HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr next_block
        as HashMap_##_KEYTYPE_##_TYPENAME_##_key_pair _
            slots(0 to HASHMAP_CONTIGUOUS_BLOCK_N-1)
    end type

    type HashMap_##_KEYTYPE_##_TYPENAME_

        public:

            declare constructor()
            declare destructor()

            declare sub insert(_key as _KEYTYPE_, byref _item as _TYPENAME_)

            declare function remove(_key as _KEYTYPE_) as __bool

            declare function exists(_key as _KEYTYPE_) as __bool

            declare function retrieve(_key as _KEYTYPE_, _
                                      byref _item as _TYPENAME_) as __bool
            declare function retrieve(_key as _KEYTYPE_) byref as _TYPENAME_

            declare sub clear()
        protected:
            declare static sub static_construct()
            declare static sub static_destruct()

        private:
            static as HashMap_Initialization_Object init_object

            HASHMAP_DECLARE_HASH_WRAP_##_KEYTYPE_(_KEYTYPE_, _TYPENAME_)
            HASHMAP_DECLARE_HASH_##_KEYTYPE_(_KEYTYPE_, _TYPENAME_)

            declare sub init()
            declare sub clear_data()
            declare sub up_split_entry()
            declare sub down_split_entry()

            as char ptr data_
            as size_t split
            as size_t capacity
            as size_t used_size
            as size_t level
            as size_t level_wrap_mask
            as size_t level_wrap_mask_2x

            static as size_t row_size_adjust
            static as size_t row_shift_mul
    end type
    type HashMap_##_KEYTYPE_##_TYPENAME_##_Accessor extends _
        HashMap_##_KEYTYPE_##_TYPENAME_
        public:
            declare static sub construct_()
            declare static sub destruct_()
        private:
            as integer _placeholder_
    end type
    sub HashMap_##_KEYTYPE_##_TYPENAME_##_Accessor.construct_()
        static_construct()
    end sub
    sub HashMap_##_KEYTYPE_##_TYPENAME_##_Accessor.destruct_()
        static_destruct()
    end sub

    dim as HashMap_Initialization_Object _
        HashMap_##_KEYTYPE_##_TYPENAME_.init_object = _
        HashMap_Initialization_Object _
        ( _
            @HashMap_##_KEYTYPE_##_TYPENAME_##_Accessor.construct_, _
            @HashMap_##_KEYTYPE_##_TYPENAME_##_Accessor.destruct_ _
        )

    dim as size_t HashMap_##_KEYTYPE_##_TYPENAME_.row_size_adjust = 1
    dim as size_t HashMap_##_KEYTYPE_##_TYPENAME_.row_shift_mul = 0

    sub HashMap_##_KEYTYPE_##_TYPENAME_.static_construct()
        dim as size_t temp_size
        temp_size = sizeof(HashMap_##_KEYTYPE_##_TYPENAME_##_Row)
        do
            row_shift_mul += 1
            temp_size shr= 1
        loop while (temp_size <> 0)
        row_size_adjust shl= row_shift_mul
        if ((row_size_adjust shr 1) = sizeof( _
            HashMap_##_KEYTYPE_##_TYPENAME_##_Row)) then

            row_shift_mul -= 1
            row_size_adjust shr= 1
        end if
    end sub

    sub HashMap_##_KEYTYPE_##_TYPENAME_.static_destruct()
        ''
    end sub

    sub HashMap_##_KEYTYPE_##_TYPENAME_.init()
        split = 0
        level = HASHMAP_INITIAL_ROW_N
        level_wrap_mask = level - 1
        level_wrap_mask_2x = level shl 1 - 1
        used_size = 0
        capacity = HASHMAP_INITIAL_ROW_N
    end sub

    constructor HashMap_##_KEYTYPE_##_TYPENAME_()
        init()
        data_ = callocate(row_size_adjust * capacity)
    end constructor

    sub HashMap_##_KEYTYPE_##_TYPENAME_.clear_data()
        dim as integer i
        dim as HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr cur_block
        dim as HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr next_block
        dim as __bool not_first_block

        for i = 0 to capacity - 1
            cur_block = cast(HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr, _
                             data_ + i shl row_shift_mul)
            not_first_block = false
            while(cur_block)
                next_block = cur_block->next_block
                HASHMAP_##_KEYTYPE_##_DESTRUCT_LOGIC()
                if not_first_block then deallocate(cur_block)
                not_first_block = true
                cur_block = next_block
            wend
        next i
    end sub

    destructor HashMap_##_KEYTYPE_##_TYPENAME_()
        clear_data()
        deallocate(data_)
    end destructor

    HASHMAP_DEFINE_HASH_WRAP_##_KEYTYPE_(_KEYTYPE_, _TYPENAME_)
    HASHMAP_DEFINE_HASH_##_KEYTYPE_(_KEYTYPE_, _TYPENAME_)

    sub HashMap_##_KEYTYPE_##_TYPENAME_.insert _
    ( _
        _key as _KEYTYPE_, _
        byref _item as _TYPENAME_ _
    )
        dim as HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr cur_row
        cur_row = cast(HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr, _
                       data_ + hash_wrap_##_KEYTYPE_##(this, _key) shl _
                       row_shift_mul)
        while(cur_row->next_block)
            cur_row = cur_row->next_block
        wend
        if cur_row->size = HASHMAP_CONTIGUOUS_BLOCK_N then
            cur_row->next_block = callocate(HASHMAP_ROWSIZE(_KEYTYPE_, _
                                                            _TYPENAME_))
            cur_row = cur_row->next_block
        end if
        with cur_row->slots(cur_row->size)
            .data_ = _item
            HASHMAP_##_KEYTYPE_##_INSERTION_LOGIC()
        end with
        cur_row->size += 1
        used_size += 1
        if (cdbl(used_size) / (capacity * HASHMAP_CONTIGUOUS_BLOCK_N)) > _
            HASHMAP_SPLIT_RATIO then up_split_entry()
    end sub


    function HashMap_##_KEYTYPE_##_TYPENAME_.remove _
    ( _
        _key as _KEYTYPE_ _
    ) as __bool
        dim as HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr cur_row
        dim as HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr last_row
        dim as integer i
        dim as integer j
        dim as integer start
        cur_row = cast(HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr, _
                       data_ + hash_wrap_##_KEYTYPE_##(this, _key) shl _
                       row_shift_mul)
        last_row = NULL
        do
            start = cur_row->size - 1
            for i = start to 0 step -1
                HASHMAP_##_KEYTYPE_##_DELETION_LOGIC()
            next i
            last_row = cur_row
            cur_row = cur_row->next_block
        loop while (cur_row)
        return true
    end function

    function HashMap_##_KEYTYPE_##_TYPENAME_.exists _
    ( _
        _key as _KEYTYPE_ _
    ) as __bool
        dim as HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr cur_row
        dim as integer i
        dim as integer start
        cur_row = cast(HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr, _
                       data_ + hash_wrap_##_KEYTYPE_##(this, _key) shl _
                       row_shift_mul)
        do
            start = cur_row->size - 1
            for i = start to 0 step -1
                HASHMAP_##_KEYTYPE_##_EXISTS_LOGIC()
            next i
            cur_row = cur_row->next_block
        loop while (cur_row)
        return false
    end function

    function HashMap_##_KEYTYPE_##_TYPENAME_.retrieve _
    ( _
        _key as _KEYTYPE_, _
        byref _item as _TYPENAME_ _
    ) as __bool
        dim as HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr cur_row
        dim as integer i
        dim as integer start
        cur_row = cast(HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr, _
                       data_ + hash_wrap_##_KEYTYPE_##(this, _key) shl _
                       row_shift_mul)
        do
            start = cur_row->size - 1
            for i = start to 0 step -1
                HASHMAP_##_KEYTYPE_##_RETRIEVE_LOGIC()
            next i
            cur_row = cur_row->next_block
        loop while (cur_row)
        return false
    end function

    function HashMap_##_KEYTYPE_##_TYPENAME_.retrieve _
    ( _
        _key as _KEYTYPE_ _
    ) byref as _TYPENAME_
        dim as HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr cur_row
        dim as integer i
        dim as integer start
        cur_row = cast(HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr, _
                       data_ + hash_wrap_##_KEYTYPE_##(this, _key) shl _
                       row_shift_mul)
        do
            start = cur_row->size - 1
            for i = start to 0 step -1
                HASHMAP_##_KEYTYPE_##_RETRIEVE_R_LOGIC()
            next i
            cur_row = cur_row->next_block
        loop while (cur_row)
    end function

    sub HashMap_##_KEYTYPE_##_TYPENAME_.clear()
        dim as integer i
        clear_data()
        init()
        deallocate(data_)
        data_ = callocate(row_size_adjust * capacity)
    end sub

    sub HashMap_##_KEYTYPE_##_TYPENAME_.up_split_entry()
        dim as HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr cur_row
        dim as HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr next_row
        dim as HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr last_row
        dim as HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr cur_insert_row
        dim as integer i
        dim as integer j
        dim as integer start
        dim as integer insert_i
        dim as size_t new_pos

        capacity += 1
        data_ = reallocate(data_, capacity * row_size_adjust)
        cur_insert_row = cast(HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr, _
                              data_ + (capacity - 1) shl row_shift_mul)
        cur_insert_row->size = 0
        cur_insert_row->next_block = NULL
        cur_row = cast(HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr, _
                       data_ + split shl row_shift_mul)

        if cur_row->size > 0 then
            last_row = NULL
            do
                next_row = cur_row->next_block
                start = cur_row->size - 1
                i = cur_row->size - 1
                while(i >= 0)
                    HASHMAP_##_KEYTYPE_##_CALC_NEW_POS(_KEYTYPE_, i)
                    new_pos and= level_wrap_mask_2x
                    if new_pos <> split then
                        if cur_insert_row->size < _
                           HASHMAP_CONTIGUOUS_BLOCK_N then
                            cur_insert_row->size += 1
                            cur_insert_row->slots _
                            ( _
                                cur_insert_row->size - 1 _
                            ) = cur_row->slots(i)
                        else
                            cur_insert_row->next_block = callocate _
                            ( _
                                HASHMAP_ROWSIZE(_KEYTYPE_, _TYPENAME_) _
                            )
                            cur_insert_row = cur_insert_row->next_block
                            cur_insert_row->slots(0) = cur_row->slots(i)
                            cur_insert_row->size = 1
                        end if
                        for j = i to start - 1
                            cur_row->slots(j) = cur_row->slots(j + 1)
                        next j
                        cur_row->size -= 1
                        start -= 1
                    end if
                    i -= 1
                wend
                if cur_row->size = 0 then
                    if last_row = NULL then
                        if next_row then
                            *cur_row = *next_row
                            deallocate(next_row)
                        else
                            cur_row = next_row
                        end if
                    else
                        last_row->next_block = next_row
                        deallocate(cur_row)
                        cur_row = next_row
                    end if
                else
                    last_row = cur_row
                    cur_row = next_row
                end if
            loop while cur_row
        end if
        split += 1
        if split >= level then
            level shl= 1
            split = 0
            level_wrap_mask = level - 1
            level_wrap_mask_2x = level shl 1 - 1
        end if
    end sub

    sub HashMap_##_KEYTYPE_##_TYPENAME_.down_split_entry()
        dim as HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr cur_row
        dim as HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr next_row
        dim as HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr cur_insert_row
        dim as integer i
        dim as integer insert_i
        dim as integer start
        dim as size_t new_pos
        dim as __bool not_first_block

        if capacity > HASHMAP_INITIAL_ROW_N then
            if split = 0 then
                level /= 2
                split = level - 1
                level_wrap_mask = level - 1
                level_wrap_mask_2x = level shl 1 - 1
            else
                split -= 1
            end if

            cur_row = cast(HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr, _
                           data_ + (capacity - 1) shl row_shift_mul)
            if cur_row->size > 0 then
                not_first_block = false
                HASHMAP_##_KEYTYPE_##_CALC_NEW_POS(_KEYTYPE_, 0)
                new_pos and= level_wrap_mask
                cur_insert_row = cast _
                ( _
                    HashMap_##_KEYTYPE_##_TYPENAME_##_Row ptr, _
                    data_ + new_pos shl row_shift_mul _
                )
                do
                    next_row = cur_row->next_block
                    start = cur_row->size - 1
                    for i = start to 0 step -1
                        do
                            if cur_insert_row->size < _
                               HASHMAP_CONTIGUOUS_BLOCK_N then
                                cur_insert_row->size += 1
                                cur_insert_row->slots _
                                ( _
                                    cur_insert_row->size - 1 _
                                ) = cur_row->slots(i)
                                exit do
                            elseif cur_insert_row->next_block = NULL then
                                cur_insert_row->next_block = callocate _
                                ( _
                                    HASHMAP_ROWSIZE(_KEYTYPE_, _TYPENAME_) _
                                )
                                cur_insert_row = cur_insert_row->next_block
                                cur_insert_row->slots(0) = _
                                    cur_row->slots(i)
                                cur_insert_row->size = 1
                                exit do
                            else
                                cur_insert_row = cur_insert_row->next_block
                            end if
                        loop
                    next i
                    if not_first_block then deallocate(cur_row)
                    not_first_block = true
                    cur_row = next_row
                loop while (cur_row)
            end if

            capacity -= 1
            data_ = reallocate(data_, capacity * row_size_adjust)

        end if

    end sub

end namespace
#endif
#endmacro

#endif

ページの頭に戻る

補足に戻る

←リンク元に戻る　プログラム開発関連に戻る

ページ歴史:2018-05-23
日本語翻訳：WATANABE Makoto、原文著作者：Zamaster

FreeBASIC 連想配列(Ultimate FB HashMap)

連想配列(Ultimate FB HashMap) 左にメニュー・フレームが表示されていない場合は、ここをクリックして下さい

ランダムな文字列でパフォーマンスを検証

キー生成での干渉の有無チェック

品目マスタと品目オーダを照合

英文字の出現頻度を数える

hashmap2.bi

連想配列(Ultimate FB HashMap)　左にメニュー・フレームが表示されていない場合は、ここをクリックして下さい