sync: restore source from Google Drive
Sync changed files to Google Drive / sync (push) Successful in 1h45m13s
Sync changed files to Google Drive / sync (push) Successful in 1h45m13s
This commit is contained in:
admin_d committed
1 parent
e2d8247e91
commit
7063d1b1c9
993 files changed
+949976
No files matched your search
Vendored
+17
@@ -0,0 +1,17 @@
|
||||
# Закреплённые исходники
|
||||
|
||||
При запуске сервер создаёт `kam_remake/` и получает только исходный текст r16020
|
||||
плюс PascalScript по закреплённому gitlink. Полный upstream в исходный ZIP не вложен.
|
||||
Игровые ресурсы, бинарные библиотеки и release ZIP не скачиваются.
|
||||
|
||||
Команда только для подготовки кода:
|
||||
|
||||
```bash
|
||||
python3 tools/source_fetch.py
|
||||
python3 tools/source_fetch.py --verify
|
||||
```
|
||||
|
||||
Команды запускать из корня проекта. Обычно отдельный вызов не нужен:
|
||||
`build-android.sh` делает это автоматически. `SOURCE_RECEIPT.json` фиксирует каждый
|
||||
файл; лицензии исходных проектов загружаются и сохраняются вместе с исходниками.
|
||||
Не подменять baseline заглушками и не класть сюда игровые бинарные данные.
|
||||
+8
@@ -0,0 +1,8 @@
|
||||
Камэрцыйнае выкарыстанне строга забаронена!
|
||||
|
||||
Ўсе выкарыстаны імёны, сімвалы або іншыя абароненыя аўтарскімі правамі матэрыялы, з'яўляюцца ўласнасцю іх уладальнікаў.
|
||||
|
||||
Мы не нясем адказнасці, калі дадзены мод (KaM Remake) нанясе ўрон праграмнаму або апаратнаму забеспячэнню Вашага кампутара.
|
||||
|
||||
Мы мяркуем, што Вы валодаеце ўласнай ліцэнзійнай копіяй iгры "Knights and Merchants: The Peasants Rebellion", у адваротным разе Вам неабходна
|
||||
купіць яе, перад тым як Вы пачнеце iграць ў KaM Remake. Невыкананне гэтага патрабавання будзе парушэннем ліцэнзійнай дамовы.
|
||||
+7
@@ -0,0 +1,7 @@
|
||||
Комерсиалната цел е стриктно забранена!
|
||||
|
||||
Всякакви използвани имена, символи или други материали с авторско право е собственост на съответните собственици.
|
||||
|
||||
Ние не поемаме никакви отговорности, ако този мод повреди вашия софтуер или хардуер.
|
||||
|
||||
Изисква се Вие (съответният потребител/играч) да притежавате лицензирано копие на играта Knights and Merchants: The Peasants Rebellion, в противен случай трябва да си купите играта преди да играете на този мод. Ако не направите това, ще нарушите споразумението.
|
||||
+7
@@ -0,0 +1,7 @@
|
||||
商业用途是严格禁止的！
|
||||
|
||||
任何使用的名字，符号，或其他受版权保护的材料，都是其各自所有者的财产。
|
||||
|
||||
如果这个游戏程序危害你的软件或硬件，我们不承担任何责任。
|
||||
|
||||
你必须获取《骑士与商人之农民起义》的许可副本，否则你在运行游戏之前应该购买此游戏。如果不这么做，将是违反许可协议。
|
||||
+8
@@ -0,0 +1,8 @@
|
||||
Použití pro komerční účely přísně zakázáno!
|
||||
|
||||
Použité názvy, symboly a ostatní materiály náleží jejich právoplatným vlastníkům.
|
||||
|
||||
Neneseme žádnou zodpovědnost za případné poškození vašeho softwaru nebo hardwaru.
|
||||
|
||||
Je vyžadováno vlastnictví oficiální kopie hry Knights and Merchants: The Peasant Rebellion, v jiném případě si hru, prosím zakupte před použitím tohoto módu.
|
||||
Pokud tak neučiníte, porušíte licenční smlouvu.
|
||||
+8
@@ -0,0 +1,8 @@
|
||||
Commercieel gebruik van deze software is niet toegestaan!
|
||||
|
||||
Gebruik van namen, symbolen of andere beschermde material is eigendom van de respectievelijke eigenaren.
|
||||
|
||||
Wij nemen geen verantwoordelijkheid als deze mod enige schade aanricht aan software en hardware.
|
||||
|
||||
Het is nodig dat jij (speler) een licentie heb op het spel Knights and Merchants: The Peasants Rebellion, anders moet je het spel kopen voor het spelen van deze mod.
|
||||
Als dit niet wordt gedaan is dit een rechtstreekse breuk op de gebruikers licentie overeenkomst.
|
||||
+7
@@ -0,0 +1,7 @@
|
||||
Commercial use is strictly prohibited!
|
||||
|
||||
Any used names, symbols or other copyrighted material is the property of the respective owners.
|
||||
|
||||
We do not take any responsibility if this mod harms your software or hardware.
|
||||
|
||||
It is required that you (the end user/player) own a licensed copy of the game Knights and Merchants: The Peasants Rebellion, otherwise you should buy the game before using this mod. Failing to do so will be breaching the License Agreement.
|
||||
+7
@@ -0,0 +1,7 @@
|
||||
Kaubanduslik kasuamine on rangelt keelatud!
|
||||
|
||||
Iga kasutatud nimi, sümbol või muu autoriõigustega kaitstud materjal kuulub nende omanikele.
|
||||
|
||||
Me ei võta vastutust, kui see modifikatsioon kahjustab teie tarkvara või riistvara.
|
||||
|
||||
On nõutud, et Te (lõppkasutaja/mängija) omate lintsentseeritud koopiat mängust Knights and Merchants: The Peasants Rebellion, vastasel juhul Te peaksite ostma mängu enne selle modifikatsiooni kasutamist. Seda mitte tehes rikute Te litsendsi kokkulepet.
|
||||
+7
@@ -0,0 +1,7 @@
|
||||
Kaupallinen käyttö on ehdottomasti kielletty!
|
||||
|
||||
Kaikki käytetyt nimet, symbolit tai muu tekijänoikeudella suojattu materiaali ovat vastaavien omistajien omaisuutta.
|
||||
|
||||
Emme ole vastuussa mistään, jos tämä modifikaatio pelistä vahingoittaa ohjelmistojasi tai laitteistojasi.
|
||||
|
||||
Sinun (Loppukäyttäjän/Pelaajan) tulee omistaa Knights and Merchants: The Peasants Rebellion -pelin lisensoitu kopio, muuten sinun tulee ostaa peli ennen tämän modin käyttöä. Jos näin ei tehdä, se rikkoo lisenssisopimusta.
|
||||
+8
@@ -0,0 +1,8 @@
|
||||
L'utilisation commerciale de ce logiciel est strictement interdite !
|
||||
|
||||
Tous les noms, symboles ou autres matériaux sous copyright utilisés sont de la propriété de leurs auteurs respectifs.
|
||||
|
||||
Nous ne prendrons aucune responsabilité si cette modification entraîne l'endommagement de votre logiciel ou de votre matériel.
|
||||
|
||||
Il est nécessaire que vous (utilisateur final) ayez une copie du jeu Knights and Merchants : The Peasants Rebellion sous licence, autrement il vous faudra l'acheter avant de pouvoir utiliser cette modification.
|
||||
Ne pas le faire serait briser le Contrat de licence.
|
||||
+8
@@ -0,0 +1,8 @@
|
||||
Kommerzielle Benutzung ist strengstens untersagt!
|
||||
|
||||
Sämtliche Namen, Symbole oder anderes urheberrechtlich geschütztes Material ist das Eigentum des jeweiligen Besitzers.
|
||||
|
||||
Wir übernehmen keinerlei Verantwortung, wenn diese Mod Ihrer Software oder Hardware schadet.
|
||||
|
||||
Es wird vorausgesetzt, dass eine lizenzierte Kopie von Knights and Merchants: The Peasants Rebellion vorhanden ist, andererseits muss das Spiel erst vor dem Einsatz der Mod gekauft werden.
|
||||
Sollte versucht werden, dies zu umgehen, wird die Lizenzvereinbarung verletzt.
|
||||
+10
@@ -0,0 +1,10 @@
|
||||
Kereskedelmi forgalomba hozni tilos!
|
||||
|
||||
Minden használt név, szimbólum vagy egyéb jogvédett tartalom a megfelelő tulajdonosok tulajdonát képezik.
|
||||
.
|
||||
|
||||
Nem vállalunk semmilyen felelősséget, ha ez a módosítás kárt okoz a szoftverben vagy hardverben.
|
||||
|
||||
Szükséges, hogy a felhasználó/játékos birtokában legyen egy legális példány a Knights and Merchants: A Parasztfelkelés játékból, különben a mod használata előtt ezt meg kell vásárolni.
|
||||
.
|
||||
Ennek elmulasztása a licencszerződés megszegését jelenti.
|
||||
+7
@@ -0,0 +1,7 @@
|
||||
L'uso commerciale è severamente vietato!
|
||||
|
||||
Tutti i nomi, i simboli o altro materiale coperto da copyright che siano stati utilizzati appartengono ai rispettivi proprietari.
|
||||
|
||||
Non ci assumiamo alcuna responsabilità per eventuali danni software o hardware causati da questa mod.
|
||||
|
||||
È necessario che voi (l'utente finale/giocatore) possediate una copia autorizzata del gioco "Knights and Merchants: The Peasants Rebellion"; in caso contrario, dovete acquistarne una prima di utilizzare questa mod. Non farlo costituisce violazione del Contrato di Licenza.
|
||||
+7
@@ -0,0 +1,7 @@
|
||||
商業の使用が厳格に禁止されましているよ。
|
||||
|
||||
何らかの使っている名前や記号や他の著作権で保護される材料は それぞれの所有者に財産です。
|
||||
|
||||
このMODはアナタのハードウェアまたはソフトウェアを損なったら，我々が引責されない。
|
||||
|
||||
所有される"Knights and Merchants: The Peasants Rebellion"ゲームのライセンスコピーは必要です。さもなければ、このmodを使用する前にオリジナルのゲームを購入する必要があります。そうしないとライセンス契約が突破されます。
|
||||
+7
@@ -0,0 +1,7 @@
|
||||
상업적인 목적으로 사용되는것을 엄격하게 금지합니다.!
|
||||
|
||||
이 게임에 사용되는 모든 이름, 기호 또는 그외 저작권이 있는 자료들은 해당 소유자의 재산입니다.
|
||||
|
||||
이 모드(MOD)는 소프트웨어 또는 하드웨어를 손상시킬경우 어떤 법적 책임을 지지 않습니다.
|
||||
|
||||
귀하(최종 사용자/플레이어)는 '기사와 상인: 농민의 반란' 게임의 정품을 소유해야 합니다, 그렇지 않으면 귀하는 이 모드를 사용하기 전에 게임을 구매해야 합니다. 그렇게하지 않으면 사용권 계약을 위반하는 것입니다.
|
||||
+7
@@ -0,0 +1,7 @@
|
||||
Kommersiell bruk er strengt forbudt!
|
||||
|
||||
Alle brukte navn, symboler eller annet opphavsrettsbeskyttet materiale eies av deres juridiske eiere.
|
||||
|
||||
Vi tar intet ansvar dersom denne modifikasjonen skader din programvare eller maskinvare.
|
||||
|
||||
Det kreves at du (sluttbrukeren/-spilleren) eier en lisensert kopi av spillet Knights and Merchants: The Peasants Rebellion, ellers burde du kjøpe spillet før du bruker denne modifikasjonen. Dersom dette ikke følges, er det et brudd på lisensavtalen.
|
||||
+8
@@ -0,0 +1,8 @@
|
||||
Komercyjne użycie jest surowo zabronione!
|
||||
|
||||
Wszelkie użyte nazwy, symbole i inne materiały chronione prawem autorskim są własnością poszczególnych właścicieli.
|
||||
|
||||
Nie bierzemy żadnej odpowiedzialności, jeśli ten mod uszkodzi twoje oprogramowanie lub sprzęt.
|
||||
|
||||
Wymagane jest posiadanie własnej licencjonowanej kopii gry Knights and Merchants: The Peasants Rebellion, w przeciwnym razie należy kupić grę przed użyciem tego moda.
|
||||
W przeciwnym razie będzie to naruszeniem umowy licencyjnej.
|
||||
+8
@@ -0,0 +1,8 @@
|
||||
O uso comercial é estritamente proibido!
|
||||
|
||||
Qualquer nome, símbolo ou outros materiais usados, com direitos autorais são de propriedade de seus respectivos proprietários.
|
||||
|
||||
Nós não nos responsabilizamos caso esse mod cause danos ao seu software ou hardware.
|
||||
|
||||
É necessário que você (usuário final/jogador) tenha uma cópia licenciada do jogo Knights and Merchants: The Peasants Rebellion
|
||||
Caso não tenha, você estará violando o Contrato de Licença.
|
||||
+7
@@ -0,0 +1,7 @@
|
||||
Folosirea în scop comercial este interzisă
|
||||
|
||||
Nume, simboluri si alte material cu drepturi de autor este proprietatea detinătorilor.
|
||||
|
||||
Nu ne asumăm nicio răspundere dacă acest program vă dăunează sistemului dumneavoastră.
|
||||
|
||||
Este necesar ca din partea ta(utilizator final/jucător)să detii o copie originală a jocului Knights and Merchants: The Peasants Rebellion, altfel va trebui să cumperi jocul inainte de a folosi acest mod. Dacă nu faci asta vei încălca Licenta.
|
||||
+7
@@ -0,0 +1,7 @@
|
||||
Коммерческое использование строго запрещено!
|
||||
|
||||
Все использованные имена, символы или другие защищенные авторскими правами материалы, являются собственностью их владельцев.
|
||||
|
||||
Мы не несем ответственности, если данный мод (КаМ Ремейк) нанесет ущерб программному или аппаратному обеспечению Вашего компьютера.
|
||||
|
||||
Мы предполагаем, что Вы (пользователь/игрок) располагайте собственной лицензионной копией игры "Knights and Merchants: The Peasants Rebellion", в противном случае Вам следует купить игру, прежде чем Вы начнете играть в КаМ Ремейк. Невыполнение этого требования будет нарушением лицензионного соглашения.
|
||||
+7
@@ -0,0 +1,7 @@
|
||||
Komercialna uporaba je strogo prepovedana!
|
||||
|
||||
Katerakoli imena, simboli ali drugi materiali ki so zaščiteni s pravicam so last uglednih lastnikov.
|
||||
|
||||
Mi ne jemljemo kakršnekoli odgovornosti če ta predelava škoduje vašemu računalniku
|
||||
|
||||
potrebno je da imate vi (končni uporabnik/igralec) svojo licenčno kopijo igre Knights and Merchants: The Peasants Rebellion, če je nimate morate kupiti igro preden uporabljate to predelavo. Če tega ne boste storili boste prekršili licenčne pravila.
|
||||
+7
@@ -0,0 +1,7 @@
|
||||
¡El uso comercial está estrictamente prohibido!
|
||||
|
||||
Cualquier nombre utilizado, símbolos o cualquier otro material sujeto a copyright es propiedad de sus respectivos propietarios.
|
||||
|
||||
No nos hacemos resposables si este mod daña su software o hardware.
|
||||
|
||||
Es imprescindible que usted (el usuario final / jugador) debe tener una copia con licencia de juego de Knights and Merchants: The Peasants Rebellion, de lo contrario usted debe comprar el juego antes de usar este mod. De no hacerlo, estará violando el Acuerdo de Licencia.
|
||||
+7
@@ -0,0 +1,7 @@
|
||||
Комерцијална употреба је стриктно забрањена!
|
||||
|
||||
Било која коришћена имена, симболи или материјали под ауторским правом су власништвом својим власницима.
|
||||
|
||||
Ми не узимамо одговорност ако вам ова модификација науди систему,харедверу или софтверу.
|
||||
|
||||
Потребно је да ви као (играч/корисник) имате оригиналну копију игре Knights and Merchants: The Peasants Rebellion, у супротном требате да купите игру пре коришћења модификације. Ако не испуните потребне ствари,нећете се придржавати оригиналне лиценсе.
|
||||
+7
@@ -0,0 +1,7 @@
|
||||
Komerčné použitie je prísne zakázané!
|
||||
|
||||
Všetky použité názvy, symboly alebo iný autorsky chránený materiál je majetkom príslušných vlastníkov.
|
||||
|
||||
Nemáme žiadnu zodpovednosť, ak tento mód poškodí softvér alebo hardvér.
|
||||
|
||||
Je nutné, aby ste (koncový užívateľ / hráč) vlastnili alebo si zakúpili licencovanú kópiu hry Knights and Merchants: The Peasants Rebellion pred použitím tohto módu. Ak tak neurobíte, budú porušované licenčné zmluvy.
|
||||
+8
@@ -0,0 +1,8 @@
|
||||
Kommersiell användning är strängt förbjudet!
|
||||
|
||||
Alla använda namn, symboler och annat upphovsrättsskyddat material tillhör dess respektive ägare.
|
||||
|
||||
Vi tar inte något ansvar för eventuella skador på mjukvara eller hårdvara som en följd av att använda KaM Remake.
|
||||
|
||||
Det krävs att du (slutanvändaren/spelaren) äger ett äkta exemplar av spelet Knights och
|
||||
Merchants: The Peasants Rebellion, annars ska du köpa spelet innan du använder KaM Remake. Att inte göra det bryter mot licensavtalet.
|
||||
+5
@@ -0,0 +1,5 @@
|
||||
Ticari kullanım kesinlikle yasaktır!
|
||||
|
||||
Kullanılan her bir isim, sembol veya diğer kayıtlı metaryellerin telif hakkı oyun sahiplerine aittir.
|
||||
|
||||
Orijinal bir Knights and Merchants: The Peasants Rebellion ürününe sahip olmanız gerekmektedir, aksi takdirde bu modu kullanmadan önce oyunu satın almanız gerekmektedir. Eğer orijinal oyuna sahip değilseniz kurulum yapılmayacaktır.
|
||||
+7
@@ -0,0 +1,7 @@
|
||||
Комерційне використання суворо заборонене!
|
||||
|
||||
Будь-які використані імена, символи або інший захищений авторським правом матеріал - майно відповідних власників.
|
||||
|
||||
Ми не беремо ніякої відповідальності, якщо цей мод зашкодить вашому програмному або технічному забезпеченню.
|
||||
|
||||
Необхідно, щоб ви( користувача/гравець ) володіли ліцензійною копією ігрових Knights and Merchants : The Peasants Rebellion, інакше ви повинні купити гру перед користуванням цим модом. Якщо ви так не зробите це порушить Ліцензійну Угоду.
|
||||
@@ -0,0 +1 @@
|
||||
NET_PROTOCOL_REVISION_NUM = 16000
|
||||
Vendored
+1
@@ -0,0 +1 @@
|
||||
GAME_REVISION_NUM=16020
|
||||
Vendored
+1677
File diff suppressed because it is too large.
Load diff
Vendored
+87
@@ -0,0 +1,87 @@
|
||||
// WDC/FPC defines used for RTL-specific cases
|
||||
// If you use any Delphi compiler that is not listed here - you need to add it
|
||||
{$IFDEF VER140} {$DEFINE WDC} {$ENDIF} //Define Windows Delphi 6 compiler
|
||||
{$IFDEF VER150} {.$DEFINE WDC} {$ENDIF} //Define Windows Delphi 7 compiler //FPC >= 3.2.0 has defined VER150, so just disable it here
|
||||
{$IFDEF VER220} {$DEFINE WDC} {$ENDIF} //Define Windows Delphi XE compiler
|
||||
{$IFDEF VER230} {$DEFINE WDC} {$ENDIF} //Define Windows Delphi XE2 compiler
|
||||
{$IFDEF VER240} {$DEFINE WDC} {$ENDIF} //Define Windows Delphi XE3 compiler
|
||||
{$IFDEF VER250} {$DEFINE WDC} {$ENDIF} //Define Windows Delphi XE4 compiler
|
||||
{$IFDEF VER260} {$DEFINE WDC} {$ENDIF} //Define Windows Delphi XE5 compiler
|
||||
{$IFDEF VER270} {$DEFINE WDC} {$ENDIF} //Define Windows Delphi XE6 compiler
|
||||
{$IFDEF VER280} {$DEFINE WDC} {$ENDIF} //Define Windows Delphi XE7 compiler
|
||||
{$IFDEF VER290} {$DEFINE WDC} {$ENDIF} //Define Windows Delphi XE8 compiler
|
||||
{$IFDEF VER300} {$DEFINE WDC} {$ENDIF} //Define Windows Delphi 10 Seattle compiler
|
||||
{$IFDEF VER310} {$DEFINE WDC} {$ENDIF} //Define Windows Delphi 10.1 Berlin compiler
|
||||
{$IFDEF VER320} {$DEFINE WDC} {$ENDIF} //Define Windows Delphi 10.2 Tokyo compiler
|
||||
{$IFDEF VER330} {$DEFINE WDC} {$ENDIF} //Define Windows Delphi 10.3 Rio compiler
|
||||
{$IFDEF VER340} {$DEFINE WDC} {$ENDIF} //Define Windows Delphi 10.4 Sydney compiler
|
||||
{$IFDEF VER350} {$DEFINE WDC} {$ENDIF} //Define Windows Delphi 11 Alexandria
|
||||
{$IFDEF VER360} {$DEFINE WDC} {$DEFINE WDC12PLUS} {$ENDIF} //Define Windows Delphi 12 Yukon
|
||||
{.$DEFINE FPC} //Define Free Pascal compiler (defined automatically by Lazarus)
|
||||
|
||||
|
||||
// Lazarus compiler specific settings
|
||||
{$IFDEF FPC}
|
||||
// Set FPC to work in Delphi mode
|
||||
{$MODE Delphi}
|
||||
// Allow advanced records in Lazarus
|
||||
{$modeSwitch advancedRecords}
|
||||
|
||||
// Currently FPC does not define UNICODE define because in Delphi it means more than just a
|
||||
// default string type but a full RTL implementation : using Windows 'W' functions instead of 'A',
|
||||
// another class declarations(TStringStream for example).
|
||||
{$IFDEF FPC_UNICODESTRINGS}
|
||||
{$DEFINE UNICODE}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
// Delphi compiler specific settings
|
||||
{$IFDEF WDC}
|
||||
{$IFNDEF WDC64} // Not available on Win64
|
||||
// Project can be compiled without madExcept features (if you dont have madExcept installed)
|
||||
{$DEFINE USE_MAD_EXCEPT}
|
||||
// Delphi compiler video play
|
||||
{$DEFINE VIDEOS}
|
||||
|
||||
{.$DEFINE FASTMM}
|
||||
{$ENDIF}
|
||||
|
||||
{$DEFINE USE_VIRTUAL_TREEVIEW}
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
// Promote some warnings to errors for safety (for all our tools)
|
||||
//----------------------------------------------------------------------------------------------------
|
||||
{$IFDEF WDC}
|
||||
{$WARN HIDING_MEMBER ERROR} // W1009 Redeclaration of '%s' hides a member in the base class
|
||||
{$WARN HIDDEN_VIRTUAL ERROR} // W1010 Method '%s' hides virtual method of base type '%s'
|
||||
{$WARN GARBAGE ERROR} // W1011 Text after final 'END.' - ignored by compiler
|
||||
{$WARN BOUNDS_ERROR ERROR} // W1012 Constant expression violates subrange bounds (Delphi)
|
||||
{$WARN FOR_VARIABLE ERROR} // W1019 For loop control variable must be simple local variable (Delphi)
|
||||
{$WARN CONSTRUCTING_ABSTRACT ERROR} // W1020 Constructing instance of '%s' containing abstract method '%s.%s' (Delphi)
|
||||
{$WARN COMPARISON_FALSE ERROR} // W1021 Comparison always evaluates to False
|
||||
{$WARN COMPARISON_TRUE ERROR} // W1022 Comparison always evaluates to True
|
||||
{$WARN DUPLICATE_CTOR_DTOR ERROR} // W1029 Duplicate %s '%s' with identical parameters will be inacessible from C++ (Delphi)
|
||||
{$WARN NO_RETVAL ERROR} // W1035 Return value of function '%s' might be undefined
|
||||
{$WARN USE_BEFORE_DEF ERROR} // W1036 Variable '%s' might not have been initialized
|
||||
{$WARN FOR_LOOP_VAR_UNDEF ERROR} // W1037 FOR-Loop variable '%s' may be undefined after loop
|
||||
{$WARN UNIT_NAME_MISMATCH ERROR} // W1038 Unit identifier '%s' does not match file name (Delphi)
|
||||
{$WARN DUPLICATES_IGNORED ERROR} // W1051 Duplicate symbol names in namespace. Using '%s.%s' found in %s. Ignoring duplicate in %s
|
||||
{$ENDIF}
|
||||
|
||||
// Allows to skip secure authentication unit (KM_NetAuthSecure) if you dont have it
|
||||
{.$DEFINE DBG_SKIP_SECURE_AUTH}
|
||||
|
||||
// Enable perflog (should be disabled for release / release candidate versions)
|
||||
{$DEFINE DBG_PERFLOG}
|
||||
|
||||
// Enable asynchronous game resource loading
|
||||
{$IFNDEF NO_ASYNC_LOAD}
|
||||
{$DEFINE LOAD_GAME_RES_ASYNC}
|
||||
{$ENDIF}
|
||||
|
||||
{$DEFINE DBG_RNG_SPY}
|
||||
|
||||
// Enable some debug features
|
||||
{.$DEFINE DEBUG}
|
||||
Vendored
+661
@@ -0,0 +1,661 @@
|
||||
GNU AFFERO GENERAL PUBLIC LICENSE
|
||||
Version 3, 19 November 2007
|
||||
|
||||
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
|
||||
Everyone is permitted to copy and distribute verbatim copies
|
||||
of this license document, but changing it is not allowed.
|
||||
|
||||
Preamble
|
||||
|
||||
The GNU Affero General Public License is a free, copyleft license for
|
||||
software and other kinds of works, specifically designed to ensure
|
||||
cooperation with the community in the case of network server software.
|
||||
|
||||
The licenses for most software and other practical works are designed
|
||||
to take away your freedom to share and change the works. By contrast,
|
||||
our General Public Licenses are intended to guarantee your freedom to
|
||||
share and change all versions of a program--to make sure it remains free
|
||||
software for all its users.
|
||||
|
||||
When we speak of free software, we are referring to freedom, not
|
||||
price. Our General Public Licenses are designed to make sure that you
|
||||
have the freedom to distribute copies of free software (and charge for
|
||||
them if you wish), that you receive source code or can get it if you
|
||||
want it, that you can change the software or use pieces of it in new
|
||||
free programs, and that you know you can do these things.
|
||||
|
||||
Developers that use our General Public Licenses protect your rights
|
||||
with two steps: (1) assert copyright on the software, and (2) offer
|
||||
you this License which gives you legal permission to copy, distribute
|
||||
and/or modify the software.
|
||||
|
||||
A secondary benefit of defending all users' freedom is that
|
||||
improvements made in alternate versions of the program, if they
|
||||
receive widespread use, become available for other developers to
|
||||
incorporate. Many developers of free software are heartened and
|
||||
encouraged by the resulting cooperation. However, in the case of
|
||||
software used on network servers, this result may fail to come about.
|
||||
The GNU General Public License permits making a modified version and
|
||||
letting the public access it on a server without ever releasing its
|
||||
source code to the public.
|
||||
|
||||
The GNU Affero General Public License is designed specifically to
|
||||
ensure that, in such cases, the modified source code becomes available
|
||||
to the community. It requires the operator of a network server to
|
||||
provide the source code of the modified version running there to the
|
||||
users of that server. Therefore, public use of a modified version, on
|
||||
a publicly accessible server, gives the public access to the source
|
||||
code of the modified version.
|
||||
|
||||
An older license, called the Affero General Public License and
|
||||
published by Affero, was designed to accomplish similar goals. This is
|
||||
a different license, not a version of the Affero GPL, but Affero has
|
||||
released a new version of the Affero GPL which permits relicensing under
|
||||
this license.
|
||||
|
||||
The precise terms and conditions for copying, distribution and
|
||||
modification follow.
|
||||
|
||||
TERMS AND CONDITIONS
|
||||
|
||||
0. Definitions.
|
||||
|
||||
"This License" refers to version 3 of the GNU Affero General Public License.
|
||||
|
||||
"Copyright" also means copyright-like laws that apply to other kinds of
|
||||
works, such as semiconductor masks.
|
||||
|
||||
"The Program" refers to any copyrightable work licensed under this
|
||||
License. Each licensee is addressed as "you". "Licensees" and
|
||||
"recipients" may be individuals or organizations.
|
||||
|
||||
To "modify" a work means to copy from or adapt all or part of the work
|
||||
in a fashion requiring copyright permission, other than the making of an
|
||||
exact copy. The resulting work is called a "modified version" of the
|
||||
earlier work or a work "based on" the earlier work.
|
||||
|
||||
A "covered work" means either the unmodified Program or a work based
|
||||
on the Program.
|
||||
|
||||
To "propagate" a work means to do anything with it that, without
|
||||
permission, would make you directly or secondarily liable for
|
||||
infringement under applicable copyright law, except executing it on a
|
||||
computer or modifying a private copy. Propagation includes copying,
|
||||
distribution (with or without modification), making available to the
|
||||
public, and in some countries other activities as well.
|
||||
|
||||
To "convey" a work means any kind of propagation that enables other
|
||||
parties to make or receive copies. Mere interaction with a user through
|
||||
a computer network, with no transfer of a copy, is not conveying.
|
||||
|
||||
An interactive user interface displays "Appropriate Legal Notices"
|
||||
to the extent that it includes a convenient and prominently visible
|
||||
feature that (1) displays an appropriate copyright notice, and (2)
|
||||
tells the user that there is no warranty for the work (except to the
|
||||
extent that warranties are provided), that licensees may convey the
|
||||
work under this License, and how to view a copy of this License. If
|
||||
the interface presents a list of user commands or options, such as a
|
||||
menu, a prominent item in the list meets this criterion.
|
||||
|
||||
1. Source Code.
|
||||
|
||||
The "source code" for a work means the preferred form of the work
|
||||
for making modifications to it. "Object code" means any non-source
|
||||
form of a work.
|
||||
|
||||
A "Standard Interface" means an interface that either is an official
|
||||
standard defined by a recognized standards body, or, in the case of
|
||||
interfaces specified for a particular programming language, one that
|
||||
is widely used among developers working in that language.
|
||||
|
||||
The "System Libraries" of an executable work include anything, other
|
||||
than the work as a whole, that (a) is included in the normal form of
|
||||
packaging a Major Component, but which is not part of that Major
|
||||
Component, and (b) serves only to enable use of the work with that
|
||||
Major Component, or to implement a Standard Interface for which an
|
||||
implementation is available to the public in source code form. A
|
||||
"Major Component", in this context, means a major essential component
|
||||
(kernel, window system, and so on) of the specific operating system
|
||||
(if any) on which the executable work runs, or a compiler used to
|
||||
produce the work, or an object code interpreter used to run it.
|
||||
|
||||
The "Corresponding Source" for a work in object code form means all
|
||||
the source code needed to generate, install, and (for an executable
|
||||
work) run the object code and to modify the work, including scripts to
|
||||
control those activities. However, it does not include the work's
|
||||
System Libraries, or general-purpose tools or generally available free
|
||||
programs which are used unmodified in performing those activities but
|
||||
which are not part of the work. For example, Corresponding Source
|
||||
includes interface definition files associated with source files for
|
||||
the work, and the source code for shared libraries and dynamically
|
||||
linked subprograms that the work is specifically designed to require,
|
||||
such as by intimate data communication or control flow between those
|
||||
subprograms and other parts of the work.
|
||||
|
||||
The Corresponding Source need not include anything that users
|
||||
can regenerate automatically from other parts of the Corresponding
|
||||
Source.
|
||||
|
||||
The Corresponding Source for a work in source code form is that
|
||||
same work.
|
||||
|
||||
2. Basic Permissions.
|
||||
|
||||
All rights granted under this License are granted for the term of
|
||||
copyright on the Program, and are irrevocable provided the stated
|
||||
conditions are met. This License explicitly affirms your unlimited
|
||||
permission to run the unmodified Program. The output from running a
|
||||
covered work is covered by this License only if the output, given its
|
||||
content, constitutes a covered work. This License acknowledges your
|
||||
rights of fair use or other equivalent, as provided by copyright law.
|
||||
|
||||
You may make, run and propagate covered works that you do not
|
||||
convey, without conditions so long as your license otherwise remains
|
||||
in force. You may convey covered works to others for the sole purpose
|
||||
of having them make modifications exclusively for you, or provide you
|
||||
with facilities for running those works, provided that you comply with
|
||||
the terms of this License in conveying all material for which you do
|
||||
not control copyright. Those thus making or running the covered works
|
||||
for you must do so exclusively on your behalf, under your direction
|
||||
and control, on terms that prohibit them from making any copies of
|
||||
your copyrighted material outside their relationship with you.
|
||||
|
||||
Conveying under any other circumstances is permitted solely under
|
||||
the conditions stated below. Sublicensing is not allowed; section 10
|
||||
makes it unnecessary.
|
||||
|
||||
3. Protecting Users' Legal Rights From Anti-Circumvention Law.
|
||||
|
||||
No covered work shall be deemed part of an effective technological
|
||||
measure under any applicable law fulfilling obligations under article
|
||||
11 of the WIPO copyright treaty adopted on 20 December 1996, or
|
||||
similar laws prohibiting or restricting circumvention of such
|
||||
measures.
|
||||
|
||||
When you convey a covered work, you waive any legal power to forbid
|
||||
circumvention of technological measures to the extent such circumvention
|
||||
is effected by exercising rights under this License with respect to
|
||||
the covered work, and you disclaim any intention to limit operation or
|
||||
modification of the work as a means of enforcing, against the work's
|
||||
users, your or third parties' legal rights to forbid circumvention of
|
||||
technological measures.
|
||||
|
||||
4. Conveying Verbatim Copies.
|
||||
|
||||
You may convey verbatim copies of the Program's source code as you
|
||||
receive it, in any medium, provided that you conspicuously and
|
||||
appropriately publish on each copy an appropriate copyright notice;
|
||||
keep intact all notices stating that this License and any
|
||||
non-permissive terms added in accord with section 7 apply to the code;
|
||||
keep intact all notices of the absence of any warranty; and give all
|
||||
recipients a copy of this License along with the Program.
|
||||
|
||||
You may charge any price or no price for each copy that you convey,
|
||||
and you may offer support or warranty protection for a fee.
|
||||
|
||||
5. Conveying Modified Source Versions.
|
||||
|
||||
You may convey a work based on the Program, or the modifications to
|
||||
produce it from the Program, in the form of source code under the
|
||||
terms of section 4, provided that you also meet all of these conditions:
|
||||
|
||||
a) The work must carry prominent notices stating that you modified
|
||||
it, and giving a relevant date.
|
||||
|
||||
b) The work must carry prominent notices stating that it is
|
||||
released under this License and any conditions added under section
|
||||
7. This requirement modifies the requirement in section 4 to
|
||||
"keep intact all notices".
|
||||
|
||||
c) You must license the entire work, as a whole, under this
|
||||
License to anyone who comes into possession of a copy. This
|
||||
License will therefore apply, along with any applicable section 7
|
||||
additional terms, to the whole of the work, and all its parts,
|
||||
regardless of how they are packaged. This License gives no
|
||||
permission to license the work in any other way, but it does not
|
||||
invalidate such permission if you have separately received it.
|
||||
|
||||
d) If the work has interactive user interfaces, each must display
|
||||
Appropriate Legal Notices; however, if the Program has interactive
|
||||
interfaces that do not display Appropriate Legal Notices, your
|
||||
work need not make them do so.
|
||||
|
||||
A compilation of a covered work with other separate and independent
|
||||
works, which are not by their nature extensions of the covered work,
|
||||
and which are not combined with it such as to form a larger program,
|
||||
in or on a volume of a storage or distribution medium, is called an
|
||||
"aggregate" if the compilation and its resulting copyright are not
|
||||
used to limit the access or legal rights of the compilation's users
|
||||
beyond what the individual works permit. Inclusion of a covered work
|
||||
in an aggregate does not cause this License to apply to the other
|
||||
parts of the aggregate.
|
||||
|
||||
6. Conveying Non-Source Forms.
|
||||
|
||||
You may convey a covered work in object code form under the terms
|
||||
of sections 4 and 5, provided that you also convey the
|
||||
machine-readable Corresponding Source under the terms of this License,
|
||||
in one of these ways:
|
||||
|
||||
a) Convey the object code in, or embodied in, a physical product
|
||||
(including a physical distribution medium), accompanied by the
|
||||
Corresponding Source fixed on a durable physical medium
|
||||
customarily used for software interchange.
|
||||
|
||||
b) Convey the object code in, or embodied in, a physical product
|
||||
(including a physical distribution medium), accompanied by a
|
||||
written offer, valid for at least three years and valid for as
|
||||
long as you offer spare parts or customer support for that product
|
||||
model, to give anyone who possesses the object code either (1) a
|
||||
copy of the Corresponding Source for all the software in the
|
||||
product that is covered by this License, on a durable physical
|
||||
medium customarily used for software interchange, for a price no
|
||||
more than your reasonable cost of physically performing this
|
||||
conveying of source, or (2) access to copy the
|
||||
Corresponding Source from a network server at no charge.
|
||||
|
||||
c) Convey individual copies of the object code with a copy of the
|
||||
written offer to provide the Corresponding Source. This
|
||||
alternative is allowed only occasionally and noncommercially, and
|
||||
only if you received the object code with such an offer, in accord
|
||||
with subsection 6b.
|
||||
|
||||
d) Convey the object code by offering access from a designated
|
||||
place (gratis or for a charge), and offer equivalent access to the
|
||||
Corresponding Source in the same way through the same place at no
|
||||
further charge. You need not require recipients to copy the
|
||||
Corresponding Source along with the object code. If the place to
|
||||
copy the object code is a network server, the Corresponding Source
|
||||
may be on a different server (operated by you or a third party)
|
||||
that supports equivalent copying facilities, provided you maintain
|
||||
clear directions next to the object code saying where to find the
|
||||
Corresponding Source. Regardless of what server hosts the
|
||||
Corresponding Source, you remain obligated to ensure that it is
|
||||
available for as long as needed to satisfy these requirements.
|
||||
|
||||
e) Convey the object code using peer-to-peer transmission, provided
|
||||
you inform other peers where the object code and Corresponding
|
||||
Source of the work are being offered to the general public at no
|
||||
charge under subsection 6d.
|
||||
|
||||
A separable portion of the object code, whose source code is excluded
|
||||
from the Corresponding Source as a System Library, need not be
|
||||
included in conveying the object code work.
|
||||
|
||||
A "User Product" is either (1) a "consumer product", which means any
|
||||
tangible personal property which is normally used for personal, family,
|
||||
or household purposes, or (2) anything designed or sold for incorporation
|
||||
into a dwelling. In determining whether a product is a consumer product,
|
||||
doubtful cases shall be resolved in favor of coverage. For a particular
|
||||
product received by a particular user, "normally used" refers to a
|
||||
typical or common use of that class of product, regardless of the status
|
||||
of the particular user or of the way in which the particular user
|
||||
actually uses, or expects or is expected to use, the product. A product
|
||||
is a consumer product regardless of whether the product has substantial
|
||||
commercial, industrial or non-consumer uses, unless such uses represent
|
||||
the only significant mode of use of the product.
|
||||
|
||||
"Installation Information" for a User Product means any methods,
|
||||
procedures, authorization keys, or other information required to install
|
||||
and execute modified versions of a covered work in that User Product from
|
||||
a modified version of its Corresponding Source. The information must
|
||||
suffice to ensure that the continued functioning of the modified object
|
||||
code is in no case prevented or interfered with solely because
|
||||
modification has been made.
|
||||
|
||||
If you convey an object code work under this section in, or with, or
|
||||
specifically for use in, a User Product, and the conveying occurs as
|
||||
part of a transaction in which the right of possession and use of the
|
||||
User Product is transferred to the recipient in perpetuity or for a
|
||||
fixed term (regardless of how the transaction is characterized), the
|
||||
Corresponding Source conveyed under this section must be accompanied
|
||||
by the Installation Information. But this requirement does not apply
|
||||
if neither you nor any third party retains the ability to install
|
||||
modified object code on the User Product (for example, the work has
|
||||
been installed in ROM).
|
||||
|
||||
The requirement to provide Installation Information does not include a
|
||||
requirement to continue to provide support service, warranty, or updates
|
||||
for a work that has been modified or installed by the recipient, or for
|
||||
the User Product in which it has been modified or installed. Access to a
|
||||
network may be denied when the modification itself materially and
|
||||
adversely affects the operation of the network or violates the rules and
|
||||
protocols for communication across the network.
|
||||
|
||||
Corresponding Source conveyed, and Installation Information provided,
|
||||
in accord with this section must be in a format that is publicly
|
||||
documented (and with an implementation available to the public in
|
||||
source code form), and must require no special password or key for
|
||||
unpacking, reading or copying.
|
||||
|
||||
7. Additional Terms.
|
||||
|
||||
"Additional permissions" are terms that supplement the terms of this
|
||||
License by making exceptions from one or more of its conditions.
|
||||
Additional permissions that are applicable to the entire Program shall
|
||||
be treated as though they were included in this License, to the extent
|
||||
that they are valid under applicable law. If additional permissions
|
||||
apply only to part of the Program, that part may be used separately
|
||||
under those permissions, but the entire Program remains governed by
|
||||
this License without regard to the additional permissions.
|
||||
|
||||
When you convey a copy of a covered work, you may at your option
|
||||
remove any additional permissions from that copy, or from any part of
|
||||
it. (Additional permissions may be written to require their own
|
||||
removal in certain cases when you modify the work.) You may place
|
||||
additional permissions on material, added by you to a covered work,
|
||||
for which you have or can give appropriate copyright permission.
|
||||
|
||||
Notwithstanding any other provision of this License, for material you
|
||||
add to a covered work, you may (if authorized by the copyright holders of
|
||||
that material) supplement the terms of this License with terms:
|
||||
|
||||
a) Disclaiming warranty or limiting liability differently from the
|
||||
terms of sections 15 and 16 of this License; or
|
||||
|
||||
b) Requiring preservation of specified reasonable legal notices or
|
||||
author attributions in that material or in the Appropriate Legal
|
||||
Notices displayed by works containing it; or
|
||||
|
||||
c) Prohibiting misrepresentation of the origin of that material, or
|
||||
requiring that modified versions of such material be marked in
|
||||
reasonable ways as different from the original version; or
|
||||
|
||||
d) Limiting the use for publicity purposes of names of licensors or
|
||||
authors of the material; or
|
||||
|
||||
e) Declining to grant rights under trademark law for use of some
|
||||
trade names, trademarks, or service marks; or
|
||||
|
||||
f) Requiring indemnification of licensors and authors of that
|
||||
material by anyone who conveys the material (or modified versions of
|
||||
it) with contractual assumptions of liability to the recipient, for
|
||||
any liability that these contractual assumptions directly impose on
|
||||
those licensors and authors.
|
||||
|
||||
All other non-permissive additional terms are considered "further
|
||||
restrictions" within the meaning of section 10. If the Program as you
|
||||
received it, or any part of it, contains a notice stating that it is
|
||||
governed by this License along with a term that is a further
|
||||
restriction, you may remove that term. If a license document contains
|
||||
a further restriction but permits relicensing or conveying under this
|
||||
License, you may add to a covered work material governed by the terms
|
||||
of that license document, provided that the further restriction does
|
||||
not survive such relicensing or conveying.
|
||||
|
||||
If you add terms to a covered work in accord with this section, you
|
||||
must place, in the relevant source files, a statement of the
|
||||
additional terms that apply to those files, or a notice indicating
|
||||
where to find the applicable terms.
|
||||
|
||||
Additional terms, permissive or non-permissive, may be stated in the
|
||||
form of a separately written license, or stated as exceptions;
|
||||
the above requirements apply either way.
|
||||
|
||||
8. Termination.
|
||||
|
||||
You may not propagate or modify a covered work except as expressly
|
||||
provided under this License. Any attempt otherwise to propagate or
|
||||
modify it is void, and will automatically terminate your rights under
|
||||
this License (including any patent licenses granted under the third
|
||||
paragraph of section 11).
|
||||
|
||||
However, if you cease all violation of this License, then your
|
||||
license from a particular copyright holder is reinstated (a)
|
||||
provisionally, unless and until the copyright holder explicitly and
|
||||
finally terminates your license, and (b) permanently, if the copyright
|
||||
holder fails to notify you of the violation by some reasonable means
|
||||
prior to 60 days after the cessation.
|
||||
|
||||
Moreover, your license from a particular copyright holder is
|
||||
reinstated permanently if the copyright holder notifies you of the
|
||||
violation by some reasonable means, this is the first time you have
|
||||
received notice of violation of this License (for any work) from that
|
||||
copyright holder, and you cure the violation prior to 30 days after
|
||||
your receipt of the notice.
|
||||
|
||||
Termination of your rights under this section does not terminate the
|
||||
licenses of parties who have received copies or rights from you under
|
||||
this License. If your rights have been terminated and not permanently
|
||||
reinstated, you do not qualify to receive new licenses for the same
|
||||
material under section 10.
|
||||
|
||||
9. Acceptance Not Required for Having Copies.
|
||||
|
||||
You are not required to accept this License in order to receive or
|
||||
run a copy of the Program. Ancillary propagation of a covered work
|
||||
occurring solely as a consequence of using peer-to-peer transmission
|
||||
to receive a copy likewise does not require acceptance. However,
|
||||
nothing other than this License grants you permission to propagate or
|
||||
modify any covered work. These actions infringe copyright if you do
|
||||
not accept this License. Therefore, by modifying or propagating a
|
||||
covered work, you indicate your acceptance of this License to do so.
|
||||
|
||||
10. Automatic Licensing of Downstream Recipients.
|
||||
|
||||
Each time you convey a covered work, the recipient automatically
|
||||
receives a license from the original licensors, to run, modify and
|
||||
propagate that work, subject to this License. You are not responsible
|
||||
for enforcing compliance by third parties with this License.
|
||||
|
||||
An "entity transaction" is a transaction transferring control of an
|
||||
organization, or substantially all assets of one, or subdividing an
|
||||
organization, or merging organizations. If propagation of a covered
|
||||
work results from an entity transaction, each party to that
|
||||
transaction who receives a copy of the work also receives whatever
|
||||
licenses to the work the party's predecessor in interest had or could
|
||||
give under the previous paragraph, plus a right to possession of the
|
||||
Corresponding Source of the work from the predecessor in interest, if
|
||||
the predecessor has it or can get it with reasonable efforts.
|
||||
|
||||
You may not impose any further restrictions on the exercise of the
|
||||
rights granted or affirmed under this License. For example, you may
|
||||
not impose a license fee, royalty, or other charge for exercise of
|
||||
rights granted under this License, and you may not initiate litigation
|
||||
(including a cross-claim or counterclaim in a lawsuit) alleging that
|
||||
any patent claim is infringed by making, using, selling, offering for
|
||||
sale, or importing the Program or any portion of it.
|
||||
|
||||
11. Patents.
|
||||
|
||||
A "contributor" is a copyright holder who authorizes use under this
|
||||
License of the Program or a work on which the Program is based. The
|
||||
work thus licensed is called the contributor's "contributor version".
|
||||
|
||||
A contributor's "essential patent claims" are all patent claims
|
||||
owned or controlled by the contributor, whether already acquired or
|
||||
hereafter acquired, that would be infringed by some manner, permitted
|
||||
by this License, of making, using, or selling its contributor version,
|
||||
but do not include claims that would be infringed only as a
|
||||
consequence of further modification of the contributor version. For
|
||||
purposes of this definition, "control" includes the right to grant
|
||||
patent sublicenses in a manner consistent with the requirements of
|
||||
this License.
|
||||
|
||||
Each contributor grants you a non-exclusive, worldwide, royalty-free
|
||||
patent license under the contributor's essential patent claims, to
|
||||
make, use, sell, offer for sale, import and otherwise run, modify and
|
||||
propagate the contents of its contributor version.
|
||||
|
||||
In the following three paragraphs, a "patent license" is any express
|
||||
agreement or commitment, however denominated, not to enforce a patent
|
||||
(such as an express permission to practice a patent or covenant not to
|
||||
sue for patent infringement). To "grant" such a patent license to a
|
||||
party means to make such an agreement or commitment not to enforce a
|
||||
patent against the party.
|
||||
|
||||
If you convey a covered work, knowingly relying on a patent license,
|
||||
and the Corresponding Source of the work is not available for anyone
|
||||
to copy, free of charge and under the terms of this License, through a
|
||||
publicly available network server or other readily accessible means,
|
||||
then you must either (1) cause the Corresponding Source to be so
|
||||
available, or (2) arrange to deprive yourself of the benefit of the
|
||||
patent license for this particular work, or (3) arrange, in a manner
|
||||
consistent with the requirements of this License, to extend the patent
|
||||
license to downstream recipients. "Knowingly relying" means you have
|
||||
actual knowledge that, but for the patent license, your conveying the
|
||||
covered work in a country, or your recipient's use of the covered work
|
||||
in a country, would infringe one or more identifiable patents in that
|
||||
country that you have reason to believe are valid.
|
||||
|
||||
If, pursuant to or in connection with a single transaction or
|
||||
arrangement, you convey, or propagate by procuring conveyance of, a
|
||||
covered work, and grant a patent license to some of the parties
|
||||
receiving the covered work authorizing them to use, propagate, modify
|
||||
or convey a specific copy of the covered work, then the patent license
|
||||
you grant is automatically extended to all recipients of the covered
|
||||
work and works based on it.
|
||||
|
||||
A patent license is "discriminatory" if it does not include within
|
||||
the scope of its coverage, prohibits the exercise of, or is
|
||||
conditioned on the non-exercise of one or more of the rights that are
|
||||
specifically granted under this License. You may not convey a covered
|
||||
work if you are a party to an arrangement with a third party that is
|
||||
in the business of distributing software, under which you make payment
|
||||
to the third party based on the extent of your activity of conveying
|
||||
the work, and under which the third party grants, to any of the
|
||||
parties who would receive the covered work from you, a discriminatory
|
||||
patent license (a) in connection with copies of the covered work
|
||||
conveyed by you (or copies made from those copies), or (b) primarily
|
||||
for and in connection with specific products or compilations that
|
||||
contain the covered work, unless you entered into that arrangement,
|
||||
or that patent license was granted, prior to 28 March 2007.
|
||||
|
||||
Nothing in this License shall be construed as excluding or limiting
|
||||
any implied license or other defenses to infringement that may
|
||||
otherwise be available to you under applicable patent law.
|
||||
|
||||
12. No Surrender of Others' Freedom.
|
||||
|
||||
If conditions are imposed on you (whether by court order, agreement or
|
||||
otherwise) that contradict the conditions of this License, they do not
|
||||
excuse you from the conditions of this License. If you cannot convey a
|
||||
covered work so as to satisfy simultaneously your obligations under this
|
||||
License and any other pertinent obligations, then as a consequence you may
|
||||
not convey it at all. For example, if you agree to terms that obligate you
|
||||
to collect a royalty for further conveying from those to whom you convey
|
||||
the Program, the only way you could satisfy both those terms and this
|
||||
License would be to refrain entirely from conveying the Program.
|
||||
|
||||
13. Remote Network Interaction; Use with the GNU General Public License.
|
||||
|
||||
Notwithstanding any other provision of this License, if you modify the
|
||||
Program, your modified version must prominently offer all users
|
||||
interacting with it remotely through a computer network (if your version
|
||||
supports such interaction) an opportunity to receive the Corresponding
|
||||
Source of your version by providing access to the Corresponding Source
|
||||
from a network server at no charge, through some standard or customary
|
||||
means of facilitating copying of software. This Corresponding Source
|
||||
shall include the Corresponding Source for any work covered by version 3
|
||||
of the GNU General Public License that is incorporated pursuant to the
|
||||
following paragraph.
|
||||
|
||||
Notwithstanding any other provision of this License, you have
|
||||
permission to link or combine any covered work with a work licensed
|
||||
under version 3 of the GNU General Public License into a single
|
||||
combined work, and to convey the resulting work. The terms of this
|
||||
License will continue to apply to the part which is the covered work,
|
||||
but the work with which it is combined will remain governed by version
|
||||
3 of the GNU General Public License.
|
||||
|
||||
14. Revised Versions of this License.
|
||||
|
||||
The Free Software Foundation may publish revised and/or new versions of
|
||||
the GNU Affero General Public License from time to time. Such new versions
|
||||
will be similar in spirit to the present version, but may differ in detail to
|
||||
address new problems or concerns.
|
||||
|
||||
Each version is given a distinguishing version number. If the
|
||||
Program specifies that a certain numbered version of the GNU Affero General
|
||||
Public License "or any later version" applies to it, you have the
|
||||
option of following the terms and conditions either of that numbered
|
||||
version or of any later version published by the Free Software
|
||||
Foundation. If the Program does not specify a version number of the
|
||||
GNU Affero General Public License, you may choose any version ever published
|
||||
by the Free Software Foundation.
|
||||
|
||||
If the Program specifies that a proxy can decide which future
|
||||
versions of the GNU Affero General Public License can be used, that proxy's
|
||||
public statement of acceptance of a version permanently authorizes you
|
||||
to choose that version for the Program.
|
||||
|
||||
Later license versions may give you additional or different
|
||||
permissions. However, no additional obligations are imposed on any
|
||||
author or copyright holder as a result of your choosing to follow a
|
||||
later version.
|
||||
|
||||
15. Disclaimer of Warranty.
|
||||
|
||||
THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
|
||||
APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
|
||||
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
|
||||
OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
|
||||
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
|
||||
IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
|
||||
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
|
||||
|
||||
16. Limitation of Liability.
|
||||
|
||||
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
|
||||
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
|
||||
THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
|
||||
GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
|
||||
USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
|
||||
DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
|
||||
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
|
||||
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
|
||||
SUCH DAMAGES.
|
||||
|
||||
17. Interpretation of Sections 15 and 16.
|
||||
|
||||
If the disclaimer of warranty and limitation of liability provided
|
||||
above cannot be given local legal effect according to their terms,
|
||||
reviewing courts shall apply local law that most closely approximates
|
||||
an absolute waiver of all civil liability in connection with the
|
||||
Program, unless a warranty or assumption of liability accompanies a
|
||||
copy of the Program in return for a fee.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
|
||||
How to Apply These Terms to Your New Programs
|
||||
|
||||
If you develop a new program, and you want it to be of the greatest
|
||||
possible use to the public, the best way to achieve this is to make it
|
||||
free software which everyone can redistribute and change under these terms.
|
||||
|
||||
To do so, attach the following notices to the program. It is safest
|
||||
to attach them to the start of each source file to most effectively
|
||||
state the exclusion of warranty; and each file should have at least
|
||||
the "copyright" line and a pointer to where the full notice is found.
|
||||
|
||||
<one line to give the program's name and a brief idea of what it does.>
|
||||
Copyright (C) <year> <name of author>
|
||||
|
||||
This program is free software: you can redistribute it and/or modify
|
||||
it under the terms of the GNU Affero General Public License as published by
|
||||
the Free Software Foundation, either version 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Affero General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Affero General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
Also add information on how to contact you by electronic and paper mail.
|
||||
|
||||
If your software can interact with users remotely through a computer
|
||||
network, you should also make sure that it provides a way for users to
|
||||
get its source. For example, if your program is a web application, its
|
||||
interface could display a "Source" link that leads users to an archive
|
||||
of the code. There are many ways you could offer source, and different
|
||||
solutions will be better for different programs; see section 13 for the
|
||||
specific requirements.
|
||||
|
||||
You should also get your employer (if you work as a programmer) or school,
|
||||
if any, to sign a "copyright disclaimer" for the program, if necessary.
|
||||
For more information on this, and how to apply and follow the GNU AGPL, see
|
||||
<http://www.gnu.org/licenses/>.
|
||||
+8089
File diff suppressed because it is too large.
Load diff
+13
@@ -0,0 +1,13 @@
|
||||
RVO Library / RVO2 Library
|
||||
|
||||
Copyright © 2008-10 University of North Carolina at Chapel Hill. All rights reserved.
|
||||
|
||||
Permission to use, copy, modify, and distribute this software and its documentation for educational, research, and non-profit purposes, without fee, and without a written agreement is hereby granted, provided that the above copyright notice, this paragraph, and the following four paragraphs appear in all copies.
|
||||
|
||||
Permission to incorporate this software into commercial products may be obtained by contacting the University of North Carolina at Chapel Hill.
|
||||
|
||||
This software program and documentation are copyrighted by the University of North Carolina at Chapel Hill. The software program and documentation are supplied "as is", without any accompanying services from the University of North Carolina at Chapel Hill or the authors. The University of North Carolina at Chapel Hill and the authors do not warrant that the operation of the program will be uninterrupted or error-free. The end-user understands that the program was developed for research purposes and is advised not to rely exclusively on the program for any reason.
|
||||
|
||||
IN NO EVENT SHALL THE UNIVERSITY OF NORTH CAROLINA AT CHAPEL HILL OR ITS EMPLOYEES OR THE AUTHORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, INCLUDING LOST PROFITS, ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF NORTH CAROLINA AT CHAPEL HILL OR THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
THE UNIVERSITY OF NORTH CAROLINA AT CHAPEL HILL AND THE AUTHORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE AND ANY STATUTORY WARRANTY OF NON-INFRINGEMENT. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS" BASIS, AND THE UNIVERSITY OF NORTH CAROLINA AT CHAPEL HILL AND THE AUTHORS HAVE NO OBLIGATIONS TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||||
Vendored
+351
@@ -0,0 +1,351 @@
|
||||
unit KM_Console;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Generics.Collections,
|
||||
KM_CommonTypes, KM_NetTypes;
|
||||
|
||||
|
||||
type
|
||||
TKMChatMode = (cmAll, cmTeam, cmSpectators, cmWhisper);
|
||||
|
||||
TKMConsole = class
|
||||
private
|
||||
fLastConsoleTime: Cardinal;
|
||||
fHistory: TList<String>;
|
||||
fCurrConsoleHistoryId: Integer;
|
||||
fOnChange: TKMEvent;
|
||||
fOnPost: TUnicodeStringEvent;
|
||||
fOnPostLocal: TUnicodeStringEvent;
|
||||
fOnError: TUnicodeStringEvent;
|
||||
fMessages: UnicodeString;
|
||||
|
||||
procedure SetMessages(const aMessages: UnicodeString);
|
||||
|
||||
function TryDoCallConsoleCommand: Boolean;
|
||||
public
|
||||
Text: UnicodeString;
|
||||
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
property Messages: UnicodeString read fMessages write SetMessages;
|
||||
|
||||
property OnPost: TUnicodeStringEvent read fOnPost write fOnPost;
|
||||
property OnPostLocal: TUnicodeStringEvent read fOnPostLocal write fOnPostLocal;
|
||||
property OnError: TUnicodeStringEvent read fOnError write fOnError;
|
||||
property OnChange: TKMEvent read fOnChange write fOnChange;
|
||||
|
||||
procedure Post(aPropagate: Boolean = True);
|
||||
function IsPostAllowed: Boolean;
|
||||
function TryCallConsoleCommand: Boolean;
|
||||
|
||||
function GetNextHistoryMsg: UnicodeString;
|
||||
function GetPrevHistoryMsg: UnicodeString;
|
||||
|
||||
procedure Add(const aMessage: UnicodeString);
|
||||
procedure AddLine(const aMessage: UnicodeString);
|
||||
|
||||
procedure Clear; virtual;
|
||||
end;
|
||||
|
||||
|
||||
TKMChat = class(TKMConsole)
|
||||
private
|
||||
fMode: TKMChatMode;
|
||||
procedure SetMode(aMode: TKMChatMode);
|
||||
public
|
||||
WhisperRecipient: TKMNetHandleIndex;
|
||||
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
property Mode: TKMChatMode read fMode write SetMode;
|
||||
|
||||
procedure Clear; override;
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
gChat: TKMChat;
|
||||
|
||||
const
|
||||
CHAT_COOLDOWN = 500; //Minimum time in milliseconds between chat messages
|
||||
CHAT_TAG: array[TKMChatMode] of Integer = (
|
||||
-1, //cmAll
|
||||
-2, //cmTeam
|
||||
-3, //cmSpectators
|
||||
-1); //cmWhisper
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Math, SysUtils, StrUtils,
|
||||
KM_ResTexts,
|
||||
KM_ScriptingEvents, KM_ScriptingConsoleCommands,
|
||||
KM_Game, KM_GameInputProcess,
|
||||
KM_CommonUtils, KM_Defaults;
|
||||
|
||||
const
|
||||
DEF_CURR_CONSOLE_HISTORY_ID = -1;
|
||||
|
||||
|
||||
{ TKMConsole }
|
||||
constructor TKMConsole.Create;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
fHistory := TList<String>.Create;
|
||||
|
||||
Clear;
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMConsole.Destroy;
|
||||
begin
|
||||
FreeAndNil(fHistory);
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMConsole.Clear;
|
||||
begin
|
||||
fLastConsoleTime := 0;
|
||||
fHistory.Clear;
|
||||
fCurrConsoleHistoryId := DEF_CURR_CONSOLE_HISTORY_ID;
|
||||
Messages := '';
|
||||
Text := '';
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMConsole.SetMessages(const aMessages: UnicodeString);
|
||||
begin
|
||||
fMessages := aMessages;
|
||||
end;
|
||||
|
||||
|
||||
function TKMConsole.GetNextHistoryMsg: UnicodeString;
|
||||
begin
|
||||
if fHistory.Count = 0 then
|
||||
begin
|
||||
Result := '';
|
||||
Exit;
|
||||
end;
|
||||
|
||||
fCurrConsoleHistoryId := Min(fCurrConsoleHistoryId + 1, fHistory.Count - 1);
|
||||
Result := fHistory[fCurrConsoleHistoryId];
|
||||
end;
|
||||
|
||||
|
||||
function TKMConsole.GetPrevHistoryMsg: UnicodeString;
|
||||
begin
|
||||
if fHistory.Count = 0 then Exit('');
|
||||
|
||||
fCurrConsoleHistoryId := Max(0, fCurrConsoleHistoryId - 1);
|
||||
Result := fHistory[fCurrConsoleHistoryId];
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMConsole.Add(const aMessage: UnicodeString);
|
||||
begin
|
||||
fMessages := fMessages + aMessage;
|
||||
|
||||
if Assigned(fOnChange) then
|
||||
fOnChange;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMConsole.AddLine(const aMessage: UnicodeString);
|
||||
begin
|
||||
if fMessages <> '' then
|
||||
begin
|
||||
//if not fMessages.EndsWith('[]') then
|
||||
if not EndsText('[]', fMessages) then
|
||||
fMessages := fMessages + '[]';
|
||||
fMessages := fMessages + '|';
|
||||
end;
|
||||
|
||||
Add(aMessage);
|
||||
end;
|
||||
|
||||
|
||||
function TKMConsole.IsPostAllowed : Boolean;
|
||||
begin
|
||||
Result := (Trim(Text) <> '') and (TimeSince(fLastConsoleTime) >= CHAT_COOLDOWN)
|
||||
end;
|
||||
|
||||
|
||||
function TKMConsole.TryCallConsoleCommand: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if gGame = nil then //Can't manage console commands while not in the game
|
||||
Exit;
|
||||
|
||||
// Text starts with / and its long enough to have some script command in there
|
||||
if (Length(Text) > 1) and (Text[1] = '/') then
|
||||
begin
|
||||
if (Text[2] = '/') then
|
||||
Delete(Text, 1, 1) //Remove one of the /'s
|
||||
else
|
||||
begin
|
||||
TryDoCallConsoleCommand;
|
||||
//Add command to history, but do not propagate post to others
|
||||
Post(False);
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMConsole.TryDoCallConsoleCommand: Boolean;
|
||||
var
|
||||
I, paramsI, procParamsCnt, spacePos: Integer;
|
||||
cmdName: AnsiString;
|
||||
paramsStr, param, parsingErrorStr: String;
|
||||
params: TKMScriptCommandParamsArray;
|
||||
quoteStart, parsingError: Boolean;
|
||||
|
||||
procedure AddParam(const aParam: String);
|
||||
begin
|
||||
if aParam <> '' then
|
||||
begin
|
||||
if paramsI < Length(params) then
|
||||
params[paramsI] := aParam;
|
||||
Inc(paramsI);
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
Result := False;
|
||||
spacePos := Pos(' ', Text);
|
||||
if spacePos = 0 then
|
||||
spacePos := Length(Text) + 1;
|
||||
|
||||
cmdName := AnsiString(Copy(Text, 2, spacePos - 2));
|
||||
|
||||
if not gScriptEvents.HasConsoleCommand(cmdName)
|
||||
and Assigned(fOnError) then
|
||||
begin
|
||||
fOnError(Format(gResTexts[TX_SCRIPT_CONSOLE_CMD_NOT_FOUND], [WrapColorA(cmdName, clScriptCmdName)]));
|
||||
Exit;
|
||||
end;
|
||||
|
||||
procParamsCnt := gScriptEvents.ConsoleCommand[cmdName].ProcParamsCnt;
|
||||
|
||||
paramsStr := RightStr(Text, Length(Text) - (spacePos - 1));
|
||||
|
||||
paramsI := 0;
|
||||
param := '';
|
||||
quoteStart := False;
|
||||
paramsStr := StringReplace(paramsStr, '\''', #1, [rfReplaceAll]);
|
||||
|
||||
for I := 1 to Length(paramsStr) do
|
||||
begin
|
||||
if (paramsStr[I] = ' ') and not quoteStart then
|
||||
begin
|
||||
AddParam(param);
|
||||
param := '';
|
||||
end
|
||||
else
|
||||
if paramsStr[I] = '''' then
|
||||
quoteStart := not quoteStart
|
||||
else
|
||||
param := param + paramsStr[I];
|
||||
end;
|
||||
|
||||
AddParam(param);
|
||||
|
||||
parsingError := False;
|
||||
parsingErrorStr := Format(gResTexts[TX_SCRIPT_CONSOLE_CMD_PARSING_ERROR] + '|',
|
||||
[WrapColorA(cmdName, clScriptCmdName),
|
||||
gScriptEvents.ConsoleCommand[cmdName].Params2String(params)]);
|
||||
|
||||
if (paramsI > procParamsCnt)
|
||||
and Assigned(fOnError) then
|
||||
begin
|
||||
fOnError(parsingErrorStr +
|
||||
Format(gResTexts[TX_SCRIPT_CONSOLE_CMD_TOO_MANY_PARAMS],
|
||||
[WrapColorA(cmdName, clScriptCmdName),
|
||||
WrapColor(IntToStr(procParamsCnt), clScriptCmdParam),
|
||||
WrapColor(IntToStr(paramsI), clScriptCmdParam)])); //We Inc ParamsI at the end
|
||||
parsingError := True;
|
||||
end;
|
||||
|
||||
for I := 0 to paramsI - 1 do
|
||||
params[I] := StringReplace(params[I], #1, '''', [rfReplaceAll]);
|
||||
|
||||
for I := paramsI to MAX_SCRIPT_CONSOLE_COMMAND_PARAMS - 1 do
|
||||
params[I] := '';
|
||||
|
||||
if not gScriptEvents.ConsoleCommand[cmdName].ValidateParams(params)
|
||||
and Assigned(fOnError) then
|
||||
begin
|
||||
fOnError(parsingErrorStr +
|
||||
Format(gResTexts[TX_SCRIPT_CONSOLE_CMD_PARAMS_NOT_VALID],
|
||||
[WrapColorA(cmdName, clScriptCmdName),
|
||||
gScriptEvents.ConsoleCommand[cmdName].ParamsTypes2String]));
|
||||
parsingError := True;
|
||||
end;
|
||||
|
||||
if not parsingError then
|
||||
begin
|
||||
gGame.GameInputProcess.CmdConsoleCommand(gicScriptConsoleCommand, cmdName, params);
|
||||
if Assigned(fOnPostLocal) then
|
||||
fOnPostLocal(Format(gResTexts[TX_SCRIPT_CONSOLE_CMD_CALLED],
|
||||
[WrapColorA(cmdName, clScriptCmdName),
|
||||
gScriptEvents.ConsoleCommand[cmdName].Params2String(params)]));
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMConsole.Post(aPropagate: Boolean = True);
|
||||
begin
|
||||
fLastConsoleTime := TimeGet;
|
||||
|
||||
fHistory.Insert(0, Text);
|
||||
fCurrConsoleHistoryId := -1;
|
||||
|
||||
if aPropagate and Assigned(fOnPost) then
|
||||
fOnPost(Text);
|
||||
|
||||
Text := '';
|
||||
end;
|
||||
|
||||
|
||||
{ TKMChat }
|
||||
constructor TKMChat.Create;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
Clear;
|
||||
|
||||
gChat := Self;
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMChat.Destroy;
|
||||
begin
|
||||
gChat := nil;
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMChat.Clear;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
WhisperRecipient := -1000;
|
||||
fMode := cmAll;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMChat.SetMode(aMode: TKMChatMode);
|
||||
begin
|
||||
fMode := aMode;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
+189
@@ -0,0 +1,189 @@
|
||||
unit KM_Crashreport;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
MadExcept,
|
||||
KM_GameTypes,
|
||||
KM_Defaults;
|
||||
|
||||
type
|
||||
// Intention of this class is to encapsulate the crash report generation,
|
||||
// since it is already quite complex task and spans several methods,
|
||||
// which are not quite related to the Game's SRP
|
||||
TKMCrashReport = class
|
||||
private
|
||||
fExceptIntf: IMEException;
|
||||
fZipFile: UnicodeString;
|
||||
|
||||
fAttachedFilesStr: UnicodeString;
|
||||
procedure AttachFile(const aFile: UnicodeString);
|
||||
procedure AttachEverything;
|
||||
procedure AttachSaveFiles(const aFile: UnicodeString; aAttachRNG: Boolean = True);
|
||||
procedure AttachLoadedFiles(aAttachRNG: Boolean);
|
||||
public
|
||||
constructor Create(const aExceptIntf: IMEException; const aZipFile: UnicodeString);
|
||||
class procedure Generate(const aExceptIntf: IMEException; const aZipFile: UnicodeString);
|
||||
end;
|
||||
|
||||
implementation
|
||||
uses
|
||||
SysUtils, Math,
|
||||
KM_CommonUtils, KM_InterfaceTypes, KM_Log, KM_Game;
|
||||
|
||||
|
||||
constructor TKMCrashReport.Create(const aExceptIntf: IMEException; const aZipFile: UnicodeString);
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
fExceptIntf := aExceptIntf;
|
||||
fZipFile := aZipFile;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCrashReport.AttachFile(const aFile: UnicodeString);
|
||||
begin
|
||||
if (aFile <> '') and FileExists(aFile) then
|
||||
begin
|
||||
if Pos(aFile, fAttachedFilesStr) = 0 then
|
||||
begin
|
||||
fAttachedFilesStr := fAttachedFilesStr + aFile + '; ';
|
||||
fExceptIntf.AdditionalAttachments.Add(aFile, '', fZipFile);
|
||||
gLog.AddTime('Attached file: ' + aFile);
|
||||
end
|
||||
else
|
||||
gLog.AddTime('File already attached: ' + aFile);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCrashReport.AttachSaveFiles(const aFile: UnicodeString; aAttachRNG: Boolean = True);
|
||||
begin
|
||||
AttachFile(ChangeFileExt(aFile, EXT_SAVE_MAIN_DOT));
|
||||
AttachFile(ChangeFileExt(aFile, EXT_SAVE_BASE_DOT));
|
||||
AttachFile(ChangeFileExt(aFile, EXT_SAVE_REPLAY_DOT));
|
||||
AttachFile(ChangeFileExt(aFile, EXT_SAVE_MP_LOCAL_DOT));
|
||||
if aAttachRNG then
|
||||
AttachFile(ChangeFileExt(aFile, EXT_SAVE_RNG_LOG_DOT));
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCrashReport.AttachLoadedFiles(aAttachRNG: Boolean);
|
||||
begin
|
||||
if gGame.SaveFile = '' then Exit;
|
||||
|
||||
gLog.AddTime('Attaching game loaded file: ' + ExeDir + gGame.SaveFile);
|
||||
AttachSaveFiles(ExeDir + gGame.SaveFile, aAttachRNG);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCrashReport.AttachEverything;
|
||||
var
|
||||
index: Byte;
|
||||
missionFile, path: UnicodeString;
|
||||
searchRec: TSearchRec;
|
||||
indexesSet: set of Byte;
|
||||
begin
|
||||
gLog.AddTime('Creating crash report...');
|
||||
|
||||
// Attempt to save the game, but if the state is too messed up it might fail
|
||||
gGame.SaveWorkerThreadHolder.Worker.fSynchronousExceptionMode := True; //Do saving synchronously in main thread
|
||||
try
|
||||
try
|
||||
if (gGame.Params.Mode in [gmSingle, gmCampaign, gmMulti, gmMultiSpectate])
|
||||
and not (gGame.GamePlayInterface.UIMode = umReplay) then //In case game mode was altered or loaded with logical error
|
||||
begin
|
||||
gGame.Save(CRASHREPORT_SAVE_NAME, UTCNow, gGame.SaveWorkerThreadHolder.Worker);
|
||||
gGame.SaveWorkerThreadHolder.Worker.WaitForAllWorkToComplete; //Wait till save is made
|
||||
AttachSaveFiles(gGame.SaveName(CRASHREPORT_SAVE_NAME, EXT_SAVE_MAIN, gGame.Params.IsMultiPlayerOrSpec));
|
||||
end;
|
||||
except
|
||||
on E : Exception do
|
||||
gLog.AddTime('Exception while trying to save game for crash report: ' + E.ClassName + ': ' + E.Message
|
||||
{$IFDEF WDC}+ sLineBreak + E.StackTrace{$ENDIF});
|
||||
end;
|
||||
finally
|
||||
gGame.SaveWorkerThreadHolder.Worker.fSynchronousExceptionMode := False;
|
||||
end;
|
||||
|
||||
missionFile := gGame.Params.MissionFileRel;
|
||||
path := ExtractFilePath(ExeDir + missionFile);
|
||||
|
||||
// Try to attach the dat+map
|
||||
AttachFile(ExeDir + missionFile);
|
||||
AttachFile(ExeDir + ChangeFileExt(missionFile, '.map'));
|
||||
AttachFile(ExeDir + ChangeFileExt(missionFile, '.txt'));
|
||||
|
||||
// Try to add main script file and all other scripts, because they could be included
|
||||
if FileExists(ExeDir + ChangeFileExt(missionFile, '.script')) then
|
||||
begin
|
||||
FindFirst(path + '*.script', faAnyFile - faDirectory, searchRec);
|
||||
try
|
||||
repeat
|
||||
if (searchRec.Name <> '.') and (searchRec.Name <> '..') then
|
||||
AttachFile(path + searchRec.Name);
|
||||
until (FindNext(searchRec) <> 0);
|
||||
finally
|
||||
FindClose(searchRec);
|
||||
end;
|
||||
end;
|
||||
|
||||
// Try to add libx files
|
||||
FindFirst(path + '*.libx', faAnyFile - faDirectory, searchRec);
|
||||
try
|
||||
repeat
|
||||
if (searchRec.Name <> '.') and (searchRec.Name <> '..') then
|
||||
AttachFile(path + searchRec.Name);
|
||||
until (FindNext(searchRec) <> 0);
|
||||
finally
|
||||
FindClose(searchRec);
|
||||
end;
|
||||
|
||||
if gGame.Params.IsReplay
|
||||
or ((gGame.GamePlayInterface <> nil) and (gGame.GamePlayInterface.UIMode = umReplay)) then //In case game mode was altered or loaded with logical error
|
||||
// For replays attach only replay save files
|
||||
AttachLoadedFiles(False)
|
||||
else
|
||||
if not gGame.Params.IsMapEditor then // no need autosaves for MapEd error...
|
||||
begin
|
||||
// For other game modes attach last saves
|
||||
|
||||
// We want to attach up to 3 saves, lets determine what are best indexes of last saves to attach
|
||||
indexesSet := [];
|
||||
// 0 is the oldest save
|
||||
case gGame.LastSaves.Count of
|
||||
0: ;
|
||||
1,2,3: indexesSet := [0,1,2];
|
||||
4: indexesSet := [0,2,3];
|
||||
else
|
||||
indexesSet := [0, gGame.LastSaves.Count div 2, gGame.LastSaves.Count - 1];
|
||||
end;
|
||||
|
||||
for index in indexesSet do
|
||||
begin
|
||||
if index >= gGame.LastSaves.Count then Break;
|
||||
|
||||
AttachSaveFiles(gGame.SaveName(gGame.LastSaves[index], EXT_SAVE_MAIN, gGame.Params.IsMultiPlayerOrSpec));
|
||||
end;
|
||||
|
||||
// It could be usefull to attach loaded file, to check what was wrong there
|
||||
AttachLoadedFiles(True); // Also attach RNG file
|
||||
end;
|
||||
|
||||
gLog.AddTime('Crash report created');
|
||||
end;
|
||||
|
||||
|
||||
class procedure TKMCrashReport.Generate(const aExceptIntf: IMEException; const aZipFile: UnicodeString);
|
||||
var
|
||||
cr: TKMCrashReport;
|
||||
begin
|
||||
cr := TKMCrashReport.Create(aExceptIntf, aZipFile);
|
||||
try
|
||||
cr.AttachEverything;
|
||||
finally
|
||||
cr.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
+189
@@ -0,0 +1,189 @@
|
||||
unit KM_Exceptions;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
MadExcept, madNVAssistant;
|
||||
|
||||
|
||||
type
|
||||
TKMExceptions = class
|
||||
private
|
||||
procedure DoException(const ExceptIntf: IMEException; var Handled: boolean);
|
||||
public
|
||||
constructor Create;
|
||||
procedure LoadTranslation;
|
||||
end;
|
||||
|
||||
//MadExcept requires this to not be within an object for some reason
|
||||
procedure DoCreateAssistant(const assistant: INVAssistant; const exception: IUnknown);
|
||||
|
||||
var
|
||||
gExceptions: TKMExceptions;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
SysUtils,
|
||||
KM_FileIO, KM_Cursor,
|
||||
KM_GameApp, KM_CrashReport, KM_Game,
|
||||
KM_Log, KM_ResTexts, KM_Defaults, KM_Points,
|
||||
KM_CommonExceptions, KM_Settings, KM_GameAppSettings, KM_ServerSettings;
|
||||
|
||||
|
||||
{ TKMExceptions }
|
||||
constructor TKMExceptions.Create;
|
||||
begin
|
||||
inherited;
|
||||
OnAssistantCreate := DoCreateAssistant;
|
||||
RegisterExceptionHandler(DoException, stTrySyncCallAlways);
|
||||
MESettings.HttpServer := 'http://master.kamremake.com/crashupload.php?rev=' + GAME_REVISION;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMExceptions.LoadTranslation;
|
||||
begin
|
||||
if gResTexts = nil then Exit; // If the exception happens before translations are loaded
|
||||
|
||||
MESettings.ExceptMsg := gResTexts[TX_ERROR_MESSAGE];
|
||||
MESettings.SendBtnCaption := gResTexts[TX_ERROR_SEND];
|
||||
MESettings.ShowBtnCaption := gResTexts[TX_ERROR_SHOW_DATA];
|
||||
MESettings.CloseBtnCaption := gResTexts[TX_ERROR_TERMINATE];
|
||||
MESettings.ContinueBtnCaption := gResTexts[TX_ERROR_RESUME];
|
||||
MESettings.SendBoxTitle := gResTexts[TX_ERROR_SENDING_TITLE];
|
||||
MESettings.SendMailMsg := gResTexts[TX_ERROR_SENDING_DATA];
|
||||
MESettings.SendAttachMsg := gResTexts[TX_ERROR_SENDING_DATA];
|
||||
MESettings.SendFinalizeMsg := gResTexts[TX_ERROR_SENDING_DATA];
|
||||
MESettings.PrepareAttachMsg := gResTexts[TX_ERROR_SENDING_CONNECTING];
|
||||
MESettings.ConnectMsg := gResTexts[TX_ERROR_SENDING_CONNECTING];
|
||||
MESettings.SendFailureMsg := gResTexts[TX_ERROR_SENDING_FAILED];
|
||||
MESettings.PleaseWaitTitle := gResTexts[TX_ERROR_WAIT_TITLEBAR];
|
||||
MESettings.PleaseWaitText := gResTexts[TX_ERROR_WAIT_MESSAGE];
|
||||
end;
|
||||
|
||||
|
||||
// We have to load the translations for the send assistant when it is created, that's the only way
|
||||
procedure DoCreateAssistant(const assistant: INVAssistant; const exception: IUnknown);
|
||||
begin
|
||||
if gResTexts = nil then Exit; // If the exception happens before translations are loaded
|
||||
|
||||
if assistant.FormCount = 3 then //That's how we know it's the send assistant, not one of the others (which we currently don't use)
|
||||
begin
|
||||
assistant.Title := gResTexts[TX_ERROR_SEND];
|
||||
//Contact details form
|
||||
assistant.Forms[0].Message := gResTexts[TX_ERROR_SEND_CONTACT];
|
||||
assistant.Forms[0].nvLabel('Label1').Caption := gResTexts[TX_ERROR_SEND_NAME];
|
||||
assistant.Forms[0].nvLabel('Label2').Caption := gResTexts[TX_ERROR_SEND_EMAIL];
|
||||
assistant.Forms[0].nvCheckBox('MemCheck').Caption := gResTexts[TX_ERROR_SEND_REMEMBER];
|
||||
assistant.Forms[0].ContinueButton.Caption := gResTexts[TX_ERROR_SEND_NEXT];
|
||||
assistant.Forms[0].CancelButton.Caption := gResTexts[TX_ERROR_SEND_CANCEL];
|
||||
|
||||
//Error details form
|
||||
assistant.Forms[1].Message := gResTexts[TX_ERROR_SEND_DETAILS];
|
||||
assistant.Forms[1].nvLabel('Label1').Caption := gResTexts[TX_ERROR_SEND_DETAILS_MESSAGE];
|
||||
assistant.Forms[1].ContinueButton.Caption := gResTexts[TX_ERROR_SEND_NEXT];
|
||||
assistant.Forms[1].CancelButton.Caption := gResTexts[TX_ERROR_SEND_CANCEL];
|
||||
|
||||
//Screenshot form
|
||||
assistant.Forms[2].Message := gResTexts[TX_ERROR_SEND_SCREENSHOT];
|
||||
assistant.Forms[2].nvCheckBox('AttachCheck').Caption := gResTexts[TX_ERROR_SEND_SCREENSHOT_MESSAGE];
|
||||
assistant.Forms[2].nvLabel('Label1').Caption := gResTexts[TX_ERROR_SEND_SCREENSHOT_EDIT];
|
||||
assistant.Forms[2].ContinueButton.Caption := gResTexts[TX_ERROR_SEND_SEND];
|
||||
assistant.Forms[2].CancelButton.Caption := gResTexts[TX_ERROR_SEND_CANCEL];
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMExceptions.DoException(const ExceptIntf: IMEException; var Handled: boolean);
|
||||
|
||||
var
|
||||
crashFile: string;
|
||||
|
||||
procedure AttachFile(const aFile: UnicodeString);
|
||||
begin
|
||||
if (aFile <> '') and FileExists(aFile) then
|
||||
begin
|
||||
ExceptIntf.AdditionalAttachments.Add(aFile, '', crashFile);
|
||||
gLog.AddTime('Attached file: ' + aFile);
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
logMessage, viewportStr: string;
|
||||
sharedSettingsPath: string;
|
||||
begin
|
||||
if gLog = nil then Exit; //Could crash very early before even the log file is created
|
||||
|
||||
//It's nice to know when the exception happened in our log if the user decides to play on and sends the report later
|
||||
logMessage := 'Exception occurred [' + ExceptIntf.ExceptClass + ']: ' + ExceptIntf.ExceptMessage;
|
||||
if ExceptIntf.ExceptObject is ELocError then
|
||||
logMessage := logMessage + ' at location ' + TypeToString(ELocError(ExceptIntf.ExceptObject).Loc);
|
||||
gLog.AddTime(logMessage);
|
||||
gLog.AddNoTime('================================================================================');
|
||||
gLog.AddNoTime(' START BUG REPORT ');
|
||||
gLog.AddNoTime('================================================================================');
|
||||
gLog.AddNoTime(ExceptIntf.BugReport);
|
||||
gLog.AddNoTime('================================================================================');
|
||||
gLog.AddNoTime(' END BUG REPORT ');
|
||||
gLog.AddNoTime('================================================================================');
|
||||
|
||||
//Append the exception message on a new paragraph of the dialog. It might be useful to the user (e.g. file permissions wrong)
|
||||
//and sometimes people send us a screenshot of the crash report window, it would be nice to know what the error was from that.
|
||||
if gResTexts <> nil then
|
||||
ExceptIntf.ExceptMsg := gResTexts[TX_ERROR_MESSAGE]+#13#10+#13#10+logMessage
|
||||
else
|
||||
//Still need a sensible message if gResTexts failed to load for some reason. ENG is default
|
||||
ExceptIntf.ExceptMsg := 'An error occurred in the application. Please click Send Bug Report so we can investigate this issue. Thanks for your help!'+#13#10+#13#10+logMessage;
|
||||
|
||||
//We want to add some of our own files to the report
|
||||
crashFile := 'KaM_Crash_' + UnicodeString(GAME_REVISION) + '_' + FormatDateTime('yyyy-mm-dd_hh-nn-ss', Now) + '.zip';
|
||||
MESettings.BugReportZip := crashFile; //Exception info also goes in the zip
|
||||
MESettings.ScreenShotZip := crashFile; //Screenshot also goes in the zip
|
||||
|
||||
if gGame <> nil then
|
||||
begin
|
||||
TKMCrashReport.Generate(ExceptIntf, crashFile);
|
||||
viewportStr := gGame.ActiveInterface.Viewport.ToStr();
|
||||
end
|
||||
else
|
||||
viewportStr := 'nil';
|
||||
|
||||
// Do the log after gGame because gGame adds stuff to the log
|
||||
if gLog <> nil then
|
||||
begin
|
||||
if gGameApp <> nil then
|
||||
gLog.AddTime('UI at crash time: MainPanel sizes: %s, cursor pos: %s, viewport: %s,' + sLineBreak +
|
||||
'CtrlDown = %s' + sLineBreak +
|
||||
'CtrlOver = %s' + sLineBreak +
|
||||
'CtrlUp = %s' + sLineBreak +
|
||||
'CtrlFocus = %s',
|
||||
[gGameApp.ActiveInterface.GetMainPanelSize.ToString, viewportStr, gCursor.Pixel.ToString,
|
||||
gGameApp.ActiveInterface.MyControls.CtrlDown.ToStr,
|
||||
gGameApp.ActiveInterface.MyControls.CtrlOver.ToStr,
|
||||
gGameApp.ActiveInterface.MyControls.CtrlUp.ToStr,
|
||||
gGameApp.ActiveInterface.MyControls.CtrlFocus.ToStr]);
|
||||
|
||||
AttachFile(gLog.LogPath);
|
||||
end;
|
||||
|
||||
sharedSettingsPath := TKMSettings.GetDir;
|
||||
|
||||
// Do settings here not in gGame because we could crash before gGame is created
|
||||
if gGameAppSettings <> nil then
|
||||
AttachFile(gGameAppSettings.Path)
|
||||
else
|
||||
begin
|
||||
AttachFile(sharedSettingsPath + SETTINGS_FILE);
|
||||
AttachFile(ExeDir + SETTINGS_FILE);
|
||||
end;
|
||||
|
||||
if gServerSettings <> nil then
|
||||
ExceptIntf.AdditionalAttachments.Add(gServerSettings.Path, '', crashFile)
|
||||
else
|
||||
begin
|
||||
AttachFile(sharedSettingsPath + SERVER_SETTINGS_FILE);
|
||||
AttachFile(ExeDir + SERVER_SETTINGS_FILE);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
Vendored
+1462
File diff suppressed because it is too large.
Load diff
Vendored
+614
@@ -0,0 +1,614 @@
|
||||
unit KM_Log;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
SyncObjs, KM_CommonTypes
|
||||
{$IFDEF KMR_GAME} // Not needed for server and other tools
|
||||
, Generics.Collections
|
||||
{$ENDIF}
|
||||
;
|
||||
|
||||
|
||||
type
|
||||
// Log message type
|
||||
TKMLogMessageType = (
|
||||
lmtDefault, // Default type
|
||||
lmtDelivery, // Delivery messages
|
||||
lmtCommands, // All GIC commands
|
||||
lmtRandomChecks, // Random checks
|
||||
lmtNetConnection, // Messages about net connection/disconnection/reconnection
|
||||
lmtNetPacketOther, // Messages about net packets (all packets, except GIP commands/ping/fps)
|
||||
lmtNetPacketCommand, // Messages about GIP commands net packets
|
||||
lmtNetPacketPingFps, // Messages about ping/fps net packets
|
||||
lmtDebug // Debug
|
||||
);
|
||||
|
||||
TKMLogMessageTypeSet = set of TKMLogMessageType;
|
||||
|
||||
// Logging system
|
||||
TKMLog = class
|
||||
private
|
||||
CS: TCriticalSection;
|
||||
fLogFile: TextFile;
|
||||
fLogPath: UnicodeString;
|
||||
fWriteErrCnt: Integer;
|
||||
fFirstTick: cardinal;
|
||||
fPreviousTick: cardinal;
|
||||
fPreviousDate: TDateTime;
|
||||
|
||||
{$IFDEF KMR_GAME}
|
||||
fOnLogMessageList: TList<TUnicodeStringEvent>;
|
||||
{$ENDIF}
|
||||
|
||||
procedure Lock;
|
||||
procedure Unlock;
|
||||
|
||||
procedure InitLog;
|
||||
|
||||
procedure AppendText(aTxt: String);
|
||||
function IsFileAssignedAndAppend: Boolean;
|
||||
|
||||
procedure NotifyLogSubs(aText: UnicodeString);
|
||||
|
||||
procedure AddLineTime(const aText: UnicodeString; aLogType: TKMLogMessageType); overload;
|
||||
procedure AddLineTime(const aText: UnicodeString); overload;
|
||||
procedure AddLineNoTime(const aText: UnicodeString; aWithPrefix: Boolean = True); overload;
|
||||
procedure AddLineNoTime(const aText: UnicodeString; aLogType: TKMLogMessageType; aWithPrefix: Boolean = True); overload;
|
||||
public
|
||||
MessageTypes: TKMLogMessageTypeSet;
|
||||
constructor Create(const aPath: UnicodeString);
|
||||
destructor Destroy; override;
|
||||
|
||||
// AppendLog adds the line to Log along with time passed since previous line added
|
||||
procedure AddTime(const aText: UnicodeString); overload;
|
||||
procedure AddTime(const aText: UnicodeString; aArgs: array of const); overload;
|
||||
function IsDegubLogEnabled: Boolean;
|
||||
procedure LogDebug(const aText: UnicodeString);
|
||||
procedure LogDelivery(const aText: UnicodeString);
|
||||
procedure LogCommands(const aText: UnicodeString);
|
||||
procedure LogRandomChecks(const aText: UnicodeString);
|
||||
procedure LogNetConnection(const aText: UnicodeString);
|
||||
procedure LogNetPacketOther(const aText: UnicodeString);
|
||||
procedure LogNetPacketCommand(const aText: UnicodeString);
|
||||
procedure LogNetPacketPingFps(const aText: UnicodeString);
|
||||
function CanLogDelivery: Boolean;
|
||||
function CanLogCommands: Boolean;
|
||||
function CanLogRandomChecks: Boolean;
|
||||
function CanLogNetConnection: Boolean;
|
||||
function CanLogNetPacketOther: Boolean;
|
||||
function CanLogNetPacketCommand: Boolean;
|
||||
function CanLogNetPacketPingFps: Boolean;
|
||||
|
||||
procedure SetDefaultMessageTypes;
|
||||
|
||||
// Add line if TestValue=False
|
||||
procedure AddAssert(const aMessageText: UnicodeString);
|
||||
// AddToLog simply adds the text
|
||||
procedure AddNoTime(const aText: UnicodeString; aWithPrefix: Boolean = True);
|
||||
procedure DeleteOldLogs(aDeleteWhenOlderThanDays: Integer);
|
||||
property LogPath: UnicodeString read fLogPath; //Used by dedicated server
|
||||
// property OnLogMessage: TUnicodeStringEvent read fOnLogMessage write fOnLogMessage;
|
||||
procedure AddOnLogEventSub(const aOnLogMessage: TUnicodeStringEvent);
|
||||
procedure RemoveOnLogEventSub(const aOnLogMessage: TUnicodeStringEvent);
|
||||
end;
|
||||
|
||||
var
|
||||
gLog: TKMLog;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
{$IFDEF WDC}IOUtils,{$ENDIF}
|
||||
Classes, SysUtils,
|
||||
KM_FileIO,
|
||||
KM_Defaults, KM_CommonUtils;
|
||||
|
||||
const
|
||||
DEFAULT_LOG_TYPES_TO_WRITE: TKMLogMessageTypeSet = [lmtDefault, lmtNetConnection];
|
||||
|
||||
|
||||
type
|
||||
// New thread, in which old logs are deleted (used internally)
|
||||
TKMOldLogsDeleter = class(TThread)
|
||||
private
|
||||
fPathToLogs: UnicodeString;
|
||||
fDeleteWhenOlderThanDays: Integer;
|
||||
public
|
||||
constructor Create(const aPathToLogs: UnicodeString; aDeleteWhenOlderThanDays: Integer);
|
||||
procedure Execute; override;
|
||||
end;
|
||||
|
||||
|
||||
{ TKMOldLogsDeleter }
|
||||
constructor TKMOldLogsDeleter.Create(const aPathToLogs: UnicodeString; aDeleteWhenOlderThanDays: Integer);
|
||||
begin
|
||||
//Thread isn't started until all constructors have run to completion
|
||||
//so Create(False) may be put in front as well
|
||||
inherited Create(False);
|
||||
|
||||
{$IFDEF DEBUG}
|
||||
TThread.NameThreadForDebugging('OldLogsDeleter', ThreadID);
|
||||
{$ENDIF}
|
||||
|
||||
//Must set these values BEFORE starting the thread
|
||||
FreeOnTerminate := True; //object can be automatically removed after its termination
|
||||
fPathToLogs := aPathToLogs;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMOldLogsDeleter.Execute;
|
||||
var
|
||||
SearchRec: TSearchRec;
|
||||
fileDateTime: TDateTime;
|
||||
begin
|
||||
if not DirectoryExists(fPathToLogs) then Exit;
|
||||
try
|
||||
if FindFirst(fPathToLogs + 'KaM*.log', faAnyFile - faDirectory, SearchRec) = 0 then
|
||||
repeat
|
||||
Assert(FileAge(fPathToLogs + SearchRec.Name, fileDateTime), 'How is that it does not exists any more?');
|
||||
|
||||
if (Abs(Now - fileDateTime) > fDeleteWhenOlderThanDays) then
|
||||
KMDeleteFile(fPathToLogs + SearchRec.Name);
|
||||
until (FindNext(SearchRec) <> 0);
|
||||
finally
|
||||
FindClose(SearchRec);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{ TKMLog }
|
||||
constructor TKMLog.Create(const aPath: UnicodeString);
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
fLogPath := aPath;
|
||||
fFirstTick := TimeGet;
|
||||
fPreviousTick := TimeGet;
|
||||
SetDefaultMessageTypes;
|
||||
|
||||
if DEBUG_LOGS then
|
||||
Include(MessageTypes, lmtDebug);
|
||||
|
||||
CS := TCriticalSection.Create;
|
||||
{$IFDEF KMR_GAME}
|
||||
fOnLogMessageList := TList<TUnicodeStringEvent>.Create;
|
||||
{$ENDIF}
|
||||
|
||||
InitLog;
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMLog.Destroy;
|
||||
begin
|
||||
CS.Free;
|
||||
{$IFDEF KMR_GAME}
|
||||
fOnLogMessageList.Free;
|
||||
{$ENDIF}
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.SetDefaultMessageTypes;
|
||||
begin
|
||||
MessageTypes := DEFAULT_LOG_TYPES_TO_WRITE;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.Lock;
|
||||
begin
|
||||
CS.Enter;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.Unlock;
|
||||
begin
|
||||
CS.Leave;
|
||||
end;
|
||||
|
||||
|
||||
// Check if the log file is assigned
|
||||
// File will be appended in case the file is assigned to the file variable
|
||||
function TKMLog.IsFileAssignedAndAppend: Boolean;
|
||||
begin
|
||||
Result := True;
|
||||
try
|
||||
Append(fLogFile);
|
||||
except
|
||||
Result := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.AppendText(aTxt: String);
|
||||
const
|
||||
MAX_LOG_ERROR_CNT = 5;
|
||||
|
||||
procedure doAppend(aE: Exception = nil);
|
||||
begin
|
||||
if not IsFileAssignedAndAppend then
|
||||
begin
|
||||
AssignFile(fLogFile, fLogPath);
|
||||
Append(fLogFile);
|
||||
end;
|
||||
|
||||
// Only show few log errors, don't overspam it
|
||||
if fWriteErrCnt <= MAX_LOG_ERROR_CNT then
|
||||
begin
|
||||
if aE <> nil then
|
||||
WriteLn(fLogFile, 'Error appending to the log file using TFile.AppendAllText: ' + aE.Message);
|
||||
end
|
||||
else
|
||||
Inc(fWriteErrCnt);
|
||||
|
||||
WriteLn(fLogFile, aTxt);
|
||||
CloseFile(fLogFile);
|
||||
end;
|
||||
|
||||
|
||||
begin
|
||||
{$IFDEF WDC}
|
||||
try
|
||||
// Try to use TFile.AppendAllText for few times
|
||||
// Then use oldschool Writeln instead
|
||||
if fWriteErrCnt < MAX_LOG_ERROR_CNT then
|
||||
TFile.AppendAllText(fLogPath, aTxt + sLineBreak, TEncoding.UTF8)
|
||||
else
|
||||
doAppend();
|
||||
except
|
||||
on E: Exception do
|
||||
doAppend(E);
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.InitLog;
|
||||
const
|
||||
INIT_STR = ' Timestamp Elapsed Delta Thread Description';
|
||||
begin
|
||||
if BLOCK_FILE_WRITE then Exit;
|
||||
|
||||
try
|
||||
ForceDirectories(ExtractFilePath(fLogPath));
|
||||
|
||||
// hh:nn:ss.zzz 12345.678s 1234567ms text-text-text
|
||||
{$IFDEF WDC}
|
||||
try
|
||||
TFile.WriteAllText(fLogPath, INIT_STR + sLineBreak, TEncoding.UTF8);
|
||||
except
|
||||
on E: Exception do
|
||||
begin
|
||||
// Write to log anyway, even if we can't do it using TFile.WriteAllText
|
||||
if not IsFileAssignedAndAppend then
|
||||
begin
|
||||
AssignFile(fLogFile, fLogPath);
|
||||
Rewrite(fLogFile);
|
||||
end;
|
||||
WriteLn(fLogFile, INIT_STR);
|
||||
WriteLn(fLogFile, 'Error creating file using TFile.WriteAllText: ' + E.Message);
|
||||
CloseFile(fLogFile);
|
||||
end;
|
||||
end;
|
||||
|
||||
{$ENDIF}
|
||||
{$IFDEF FPC}
|
||||
AssignFile(fLogFile, fLogPath);
|
||||
Rewrite(fLogFile);
|
||||
// hh:nn:ss.zzz 12345.678s 1234567ms text-text-text
|
||||
WriteLn(fLogFile, ' Timestamp Elapsed Delta Thread Description');
|
||||
CloseFile(fLogFile);
|
||||
{$ENDIF}
|
||||
except
|
||||
on E: Exception do
|
||||
begin
|
||||
E.Message := E.Message + '. Tried to init Log on path ''' + fLogPath + '''';
|
||||
raise E;
|
||||
end;
|
||||
end;
|
||||
AddLineTime('Log is up and running. Game version: ' + UnicodeString(GAME_VERSION));
|
||||
end;
|
||||
|
||||
|
||||
// Run thread to delete old logs
|
||||
procedure TKMLog.DeleteOldLogs(aDeleteWhenOlderThanDays: Integer);
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
if not DELETE_OLD_LOGS then Exit;
|
||||
|
||||
// No need to remember the instance, it's set to FreeOnTerminate
|
||||
TKMOldLogsDeleter.Create(ExtractFilePath(fLogPath), aDeleteWhenOlderThanDays);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.AddOnLogEventSub(const aOnLogMessage: TUnicodeStringEvent);
|
||||
begin
|
||||
{$IFDEF KMR_GAME}
|
||||
fOnLogMessageList.Add(aOnLogMessage);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.RemoveOnLogEventSub(const aOnLogMessage: TUnicodeStringEvent);
|
||||
begin
|
||||
{$IFDEF KMR_GAME}
|
||||
fOnLogMessageList.Remove(aOnLogMessage);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.NotifyLogSubs(aText: UnicodeString);
|
||||
{$IFDEF KMR_GAME}
|
||||
var
|
||||
I: Integer;
|
||||
{$ENDIF}
|
||||
begin
|
||||
{$IFDEF KMR_GAME}
|
||||
for I := 0 to fOnLogMessageList.Count - 1 do
|
||||
if Assigned(fOnLogMessageList[I]) then
|
||||
fOnLogMessageList[I](aText);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
// Lines are timestamped, each line invokes file open/close for writing,
|
||||
// meaning that no lines will be lost if Remake crashes
|
||||
procedure TKMLog.AddLineTime(const aText: UnicodeString; aLogType: TKMLogMessageType);
|
||||
var
|
||||
txt, txt2: String;
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
|
||||
if BLOCK_FILE_WRITE then Exit;
|
||||
|
||||
if not (aLogType in MessageTypes) then // write into log only for allowed types
|
||||
Exit;
|
||||
|
||||
// Do not allow multiple threads write into the same file
|
||||
Lock;
|
||||
try
|
||||
if not FileExists(fLogPath) then
|
||||
InitLog; // Recreate log file, if it was deleted
|
||||
|
||||
txt := '';
|
||||
|
||||
{$IFDEF FPC} Append(fLogFile); {$ENDIF}
|
||||
|
||||
//Write a line when the day changed since last time (useful for dedicated server logs that could be over months)
|
||||
if Abs(Trunc(fPreviousDate) - Trunc(Now)) >= 1 then
|
||||
begin
|
||||
{$IFDEF WDC}
|
||||
txt := txt + '========================' + sLineBreak
|
||||
+ ' Date: ' + FormatDateTime('yyyy/mm/dd', Now) + sLineBreak
|
||||
+ '========================' + sLineBreak;
|
||||
{$ENDIF}
|
||||
{$IFDEF FPC}
|
||||
WriteLn(fLogFile, '========================');
|
||||
WriteLn(fLogFile, ' Date: ' + FormatDateTime('yyyy/mm/dd', Now));
|
||||
WriteLn(fLogFile, '========================');
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
txt2 := Format('%12s %9.3fs %7dms %6d %s', [
|
||||
FormatDateTime('hh:nn:ss.zzz', Now),
|
||||
TimeSince(fFirstTick) / 1000,
|
||||
TimeSince(fPreviousTick),
|
||||
TThread.CurrentThread.ThreadID,
|
||||
aText]);
|
||||
{$IFDEF WDC}
|
||||
AppendText(txt + txt2);
|
||||
{$ENDIF}
|
||||
{$IFDEF FPC}
|
||||
WriteLn(fLogFile, txt2);
|
||||
CloseFile(fLogFile);
|
||||
{$ENDIF}
|
||||
|
||||
fPreviousTick := TimeGet;
|
||||
fPreviousDate := Now;
|
||||
finally
|
||||
UnLock;
|
||||
end;
|
||||
|
||||
NotifyLogSubs(aText);
|
||||
end;
|
||||
|
||||
|
||||
// Add line with timestamp
|
||||
procedure TKMLog.AddLineTime(const aText: UnicodeString);
|
||||
begin
|
||||
AddLineTime(aText, lmtDefault);
|
||||
end;
|
||||
|
||||
|
||||
// Add line but without timestamp
|
||||
procedure TKMLog.AddLineNoTime(const aText: UnicodeString; aLogType: TKMLogMessageType; aWithPrefix: Boolean = True);
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
|
||||
if BLOCK_FILE_WRITE then Exit;
|
||||
|
||||
if not (aLogType in MessageTypes) then // write into log only for allowed types
|
||||
Exit;
|
||||
|
||||
// Do not allow multiple threads write into the same file
|
||||
Lock;
|
||||
try
|
||||
if not FileExists(fLogPath) then
|
||||
InitLog; // Recreate log file, if it was deleted
|
||||
|
||||
{$IFDEF FPC} Append(fLogFile); {$ENDIF}
|
||||
|
||||
if aWithPrefix then
|
||||
begin
|
||||
{$IFDEF WDC}
|
||||
AppendText(' ' + aText);
|
||||
{$ENDIF}
|
||||
{$IFDEF FPC}
|
||||
WriteLn(fLogFile, ' ' + aText);
|
||||
{$ENDIF}
|
||||
end
|
||||
else
|
||||
begin
|
||||
{$IFDEF WDC} AppendText(aText); {$ENDIF}
|
||||
{$IFDEF FPC} WriteLn(fLogFile, aText); {$ENDIF}
|
||||
end;
|
||||
{$IFDEF FPC} CloseFile(fLogFile); {$ENDIF}
|
||||
finally
|
||||
// Do not allow multiple threads write into the same file
|
||||
UnLock;
|
||||
end;
|
||||
|
||||
NotifyLogSubs(aText);
|
||||
end;
|
||||
|
||||
|
||||
//Add line without timestamp
|
||||
procedure TKMLog.AddLineNoTime(const aText: UnicodeString; aWithPrefix: Boolean = True);
|
||||
begin
|
||||
AddLineNoTime(aText, lmtDefault, aWithPrefix);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.AddTime(const aText: UnicodeString);
|
||||
begin
|
||||
AddLineTime(aText);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.AddTime(const aText: UnicodeString; aArgs: array of const);
|
||||
begin
|
||||
AddLineTime(Format(aText, aArgs));
|
||||
end;
|
||||
|
||||
|
||||
function TKMLog.IsDegubLogEnabled: Boolean;
|
||||
begin
|
||||
Result := lmtDebug in MessageTypes;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.LogDebug(const aText: UnicodeString);
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
AddLineTime(aText, lmtDebug);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.LogDelivery(const aText: UnicodeString);
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
AddLineTime(aText, lmtDelivery);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.LogCommands(const aText: UnicodeString);
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
AddLineTime(aText, lmtCommands);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.LogRandomChecks(const aText: UnicodeString);
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
if not CanLogRandomChecks then Exit;
|
||||
|
||||
AddLineNoTime(aText, lmtRandomChecks);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.LogNetConnection(const aText: UnicodeString);
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
AddLineTime(aText, lmtNetConnection);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.LogNetPacketOther(const aText: UnicodeString);
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
AddLineTime(aText, lmtNetPacketOther);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.LogNetPacketCommand(const aText: UnicodeString);
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
AddLineTime(aText, lmtNetPacketCommand);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.LogNetPacketPingFps(const aText: UnicodeString);
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
AddLineTime(aText, lmtNetPacketPingFps);
|
||||
end;
|
||||
|
||||
|
||||
function TKMLog.CanLogDelivery: Boolean;
|
||||
begin
|
||||
if Self = nil then Exit(False);
|
||||
Result := lmtDelivery in MessageTypes;
|
||||
end;
|
||||
|
||||
|
||||
function TKMLog.CanLogCommands: Boolean;
|
||||
begin
|
||||
if Self = nil then Exit(False);
|
||||
Result := lmtCommands in MessageTypes;
|
||||
end;
|
||||
|
||||
|
||||
function TKMLog.CanLogRandomChecks: Boolean;
|
||||
begin
|
||||
if Self = nil then Exit(False);
|
||||
Result := lmtRandomChecks in MessageTypes;
|
||||
end;
|
||||
|
||||
|
||||
function TKMLog.CanLogNetConnection: Boolean;
|
||||
begin
|
||||
if Self = nil then Exit(False);
|
||||
Result := lmtNetConnection in MessageTypes;
|
||||
end;
|
||||
|
||||
|
||||
function TKMLog.CanLogNetPacketOther: Boolean;
|
||||
begin
|
||||
if Self = nil then Exit(False);
|
||||
Result := lmtNetPacketOther in MessageTypes;
|
||||
end;
|
||||
|
||||
|
||||
function TKMLog.CanLogNetPacketCommand: Boolean;
|
||||
begin
|
||||
if Self = nil then Exit(False);
|
||||
Result := lmtNetPacketCommand in MessageTypes;
|
||||
end;
|
||||
|
||||
|
||||
function TKMLog.CanLogNetPacketPingFps: Boolean;
|
||||
begin
|
||||
if Self = nil then Exit(False);
|
||||
Result := lmtNetPacketPingFps in MessageTypes;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.AddAssert(const aMessageText: UnicodeString);
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
|
||||
AddLineNoTime('ASSERTION FAILED! Msg: ' + aMessageText);
|
||||
raise Exception.Create('ASSERTION FAILED! Msg: ' + aMessageText);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLog.AddNoTime(const aText: UnicodeString; aWithPrefix: Boolean = True);
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
|
||||
AddLineNoTime(aText, aWithPrefix);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
Vendored
+959
@@ -0,0 +1,959 @@
|
||||
unit KM_Main;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
{$IFDEF MSWindows} Windows, {$ENDIF}
|
||||
KM_Defaults, KM_FormMain, KM_FormLoading, KM_Maps,
|
||||
KM_MainSettings, KM_Resolutions, KM_Video,
|
||||
KM_WindowParams,
|
||||
KM_GameAppSettings
|
||||
{$IFDEF FPC}
|
||||
, Types
|
||||
{$ENDIF}
|
||||
;
|
||||
|
||||
|
||||
type
|
||||
// Provides basement for the Game App
|
||||
// Should be abstract enough, so that the Game could be a race-sim or a quest or any other
|
||||
TKMMain = class
|
||||
private
|
||||
fFormMain: TFormMain;
|
||||
fFormLoading: TFormLoading;
|
||||
|
||||
fGameTickInterval: Cardinal;
|
||||
|
||||
fRenderSchedule, fTickSchedule, fUpdateStateSchedule: Cardinal;
|
||||
fLastRenderTime, fOldFrameTimes, fFrameCount: Cardinal;
|
||||
{$IFDEF MSWindows}
|
||||
fMutex: THandle;
|
||||
{$ENDIF}
|
||||
|
||||
// fMainSettings: TKMainSettings;
|
||||
fResolutions: TKMResolutions;
|
||||
fMapCacheUpdater: TTMapsCacheUpdater;
|
||||
|
||||
fFPS: Single;
|
||||
fFPSString: String;
|
||||
|
||||
procedure DoRestore(Sender: TObject);
|
||||
procedure DoActivate(Sender: TObject);
|
||||
procedure DoDeactivate(Sender: TObject);
|
||||
procedure DoIdle(Sender: TObject; var Done: Boolean);
|
||||
|
||||
function GetRenderInterval: Cardinal;
|
||||
function ForcedRenderRequired: Boolean;
|
||||
|
||||
procedure DoRender;
|
||||
procedure SleepUntilNextSchedule;
|
||||
|
||||
procedure MapCacheUpdate;
|
||||
procedure UpdateFPS(latestFrameTime: Cardinal);
|
||||
|
||||
procedure GameSpeedChange(aSpeed: Single);
|
||||
function DoHaveGenericPermission: Boolean;
|
||||
|
||||
procedure TryWriteIntoGameFolder();
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
function Start: Boolean;
|
||||
procedure CloseQuery(var aCanClose: Boolean);
|
||||
procedure Stop(Sender: TObject);
|
||||
|
||||
procedure UpdateWindowParams(const aWindowParams: TKMWindowParamsRecord);
|
||||
procedure Move(const aWindowParams: TKMWindowParamsRecord);
|
||||
procedure ForceResize;
|
||||
procedure Resize(aWidth, aHeight: Integer); overload;
|
||||
procedure Resize(aWidth, aHeight: Integer; const aWindowParams: TKMWindowParamsRecord); overload;
|
||||
procedure Render;
|
||||
procedure ShowAbout;
|
||||
property FormMain: TFormMain read fFormMain;
|
||||
|
||||
procedure ApplyCursorRestriction;
|
||||
function GetScreenBounds(out aBounds: TRect): Boolean;
|
||||
function IsFormActive: Boolean;
|
||||
function ClientRect(aPixelsCntToReduce: Integer = 0): TRect;
|
||||
function ClientToScreen(aPoint: TPoint): TPoint;
|
||||
function ReinitRender(aReturnToOptions: Boolean): Boolean;
|
||||
|
||||
property FPSString: String read fFPSString;
|
||||
|
||||
function IsDebugChangeAllowed: Boolean;
|
||||
|
||||
function LockMutex: Boolean;
|
||||
procedure UnlockMutex;
|
||||
|
||||
procedure HandleStatusBarText(aPanelIndex: TKMStatusBarPanel; aText: string);
|
||||
|
||||
procedure SetGameTickInterval(aInterval: Cardinal);
|
||||
property GameTickInterval: Cardinal read fGameTickInterval;
|
||||
|
||||
property Resolutions: TKMResolutions read fResolutions;
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
gMain: TKMMain;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Classes, SysUtils, SysConst, StrUtils, Math,
|
||||
Forms,
|
||||
{$IF DEFINED(MSWindows)}
|
||||
MMSystem,
|
||||
{$ELSEIF DEFINED(Unix)}
|
||||
Dialogs, LCLType, Controls,
|
||||
{$ENDIF}
|
||||
{$IFDEF USE_MAD_EXCEPT} KM_Exceptions, {$ENDIF}
|
||||
KromUtils, KM_FileIO,
|
||||
KM_GameApp, KM_VclHelpers,
|
||||
KM_System,
|
||||
KM_ResTexts,
|
||||
KM_KeysSettings,
|
||||
KM_Music,
|
||||
KM_Log, KM_CommonUtils, KM_Points, KM_DevPerfLog,
|
||||
KM_CommonExceptions,
|
||||
KromShellUtils, KM_MapTypes;
|
||||
|
||||
|
||||
const
|
||||
// Mutex is used to block duplicate app launch on the same PC
|
||||
// Random GUID generated in Delphi by Ctrl+Shift+G
|
||||
// Generated for versions r13651+
|
||||
// We can allow to have beta and r6720 versions to be opened at the same time
|
||||
KAM_MUTEX = 'AAF80942-EC97-4D02-9339-07AB8FEFA187';
|
||||
|
||||
|
||||
{$OVERFLOWCHECKS OFF}
|
||||
function AddWithOverflow(A, B: Cardinal): Cardinal; inline;
|
||||
begin
|
||||
Result := A + B;
|
||||
end;
|
||||
{$OVERFLOWCHECKS ON}
|
||||
|
||||
|
||||
{ TKMMain }
|
||||
constructor TKMMain.Create;
|
||||
var
|
||||
collapsed: Boolean;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
|
||||
// Try to write a file into the game folder and raise an error in case we can not
|
||||
tryWriteIntoGameFolder();
|
||||
|
||||
fGameTickInterval := 100;
|
||||
|
||||
// Create exception handler as soon as possible in case it crashes early on
|
||||
{$IFDEF USE_MAD_EXCEPT}gExceptions := TKMExceptions.Create;{$ENDIF}
|
||||
|
||||
//Form created first will be on taskbar
|
||||
Application.CreateForm(TFormMain, fFormMain);
|
||||
Application.CreateForm(TFormLoading, fFormLoading);
|
||||
|
||||
{$IFDEF DBG_PERFLOG}
|
||||
gPerfLogs := TKMPerfLogs.Create([], True);
|
||||
gPerfLogs.ShowForm(fFormMain.cpPerfLogs);
|
||||
gPerfLogs.OnFormChanged := fFormMain.OtherFormChanged;
|
||||
|
||||
collapsed := fFormMain.cpPerfLogs.Collapsed; //Save collapsed flag
|
||||
fFormMain.DevSettings.SkipSave := True; // SKip save
|
||||
fFormMain.cpPerfLogs.Collapsed := False; //We can set TCategoryPanel height only when collapsed set to False
|
||||
fFormMain.cpPerfLogs.Height := gPerfLogs.FormHeight;
|
||||
fFormMain.cpPerfLogs.Collapsed := collapsed; //Restore collapsed flag
|
||||
fFormMain.DevSettings.SkipSave := False;
|
||||
{$ELSE}
|
||||
fFormMain.cpPerfLogs.Hide;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMMain.Destroy;
|
||||
begin
|
||||
// FormLoading is owned by the Application
|
||||
// If exception occurs and gMain is freed, make sure to remove fsStayOnTop from FormLoading,
|
||||
// so that madExcept dialogs (main and its child SendBugReport) are not overlapped by it
|
||||
fFormLoading.FormStyle := fsNormal;
|
||||
|
||||
{$IFDEF DBG_PERFLOG}gPerfLogs.Free;{$ENDIF}
|
||||
|
||||
{$IFDEF USE_MAD_EXCEPT}FreeAndNil(gExceptions);{$ENDIF}
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
// Try to write a file into the game folder and raise an error in case we can not
|
||||
procedure TKMMain.TryWriteIntoGameFolder();
|
||||
var
|
||||
filename: String;
|
||||
sList: TStringList;
|
||||
begin
|
||||
try
|
||||
sList := TStringList.Create;
|
||||
try
|
||||
filename := ExtractFilePath(ParamStr(0)) + PathDelim + 'test.txt';
|
||||
sList.SaveToFile(filename);
|
||||
KMDeleteFile(filename);
|
||||
finally
|
||||
sList.Free;
|
||||
end;
|
||||
except
|
||||
on E: Exception do
|
||||
begin
|
||||
raise EGameInitError.Create('Can''t write into the game folder ''' + ExtractFilePath(ParamStr(0)) + '''' + sLineBreak + sLineBreak
|
||||
+ 'Error:' + sLineBreak + E.Message + sLineBreak + sLineBreak
|
||||
+ 'Please move the game folder to a writable location or change the game folder permissions');
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
// Assertion error handler
|
||||
procedure CustomAssertErrorHandler(const Message, Filename: string; LineNumber: Integer; ErrorAddr: Pointer);
|
||||
var
|
||||
fileNameOnly: string;
|
||||
begin
|
||||
// Show only filename in the error message
|
||||
fileNameOnly := ExtractFileName(Filename);
|
||||
|
||||
if Message <> '' then
|
||||
raise EAssertionFailed.CreateFmt(SAssertError,
|
||||
[Message, fileNameOnly, LineNumber]) at ErrorAddr
|
||||
else
|
||||
raise EAssertionFailed.CreateFmt(SAssertError,
|
||||
[SAssertionFailed, fileNameOnly, LineNumber]) at ErrorAddr;
|
||||
end;
|
||||
|
||||
|
||||
// Return False in case we had difficulties on the start
|
||||
function TKMMain.Start: Boolean;
|
||||
|
||||
function GetScreenMonitorsInfo: TKMPointArray;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
SetLength(Result, Screen.MonitorCount);
|
||||
for I := 0 to Screen.MonitorCount-1 do
|
||||
begin
|
||||
Result[I].X := Screen.Monitors[I].Width;
|
||||
Result[I].Y := Screen.Monitors[I].Height;
|
||||
end;
|
||||
end;
|
||||
|
||||
const
|
||||
LOG_CREATE_TRY_CNT = 3;
|
||||
var
|
||||
tryInd: Integer;
|
||||
logsPath: UnicodeString;
|
||||
time: Cardinal;
|
||||
begin
|
||||
Result := True;
|
||||
|
||||
time := TimeGet;
|
||||
|
||||
ExeDir := ExtractFilePath(ParamStr(0));
|
||||
|
||||
// Set custom AssertErrorhandler to avoid dev paths in the error messages, which could be seen by players
|
||||
AssertErrorProc := @CustomAssertErrorHandler;
|
||||
|
||||
//Random is only used for cases where order does not matter, e.g. shuffle tracks
|
||||
Randomize;
|
||||
|
||||
fFormLoading.Label5.Caption := UnicodeString(GAME_VERSION);
|
||||
fFormLoading.Show; //This is our splash screen
|
||||
fFormLoading.Refresh;
|
||||
|
||||
{$IFDEF MSWindows}
|
||||
TimeBeginPeriod(1); //initialize timer precision
|
||||
{$ENDIF}
|
||||
|
||||
if not BLOCK_FILE_WRITE then
|
||||
begin
|
||||
tryInd := 0;
|
||||
logsPath := ExeDir + 'Logs' + PathDelim + 'KaM_' + FormatDateTime('yyyy-mm-dd_hh-nn-ss-zzz', Now) + '.log';
|
||||
// Try to create log several times
|
||||
while (gLog = nil) and (tryInd < LOG_CREATE_TRY_CNT) do
|
||||
begin
|
||||
try
|
||||
Inc(tryInd);
|
||||
CreateDir(ExeDir + 'Logs' + PathDelim);
|
||||
gLog := TKMLog.Create(logsPath); //First thing - create a log
|
||||
except
|
||||
on E: Exception do
|
||||
if tryInd < LOG_CREATE_TRY_CNT then
|
||||
Sleep(200) // Just wait a bit
|
||||
else
|
||||
raise EGameInitError.Create('Error initializing logging into file: ''' + logsPath + ''':' + sLineBreak + E.Message
|
||||
{$IFDEF WDC} + sLineBreak + E.StackTrace {$ENDIF});
|
||||
end;
|
||||
end;
|
||||
gLog.DeleteOldLogs(LOGS_DELETE_WHEN_OLDER_THAN);
|
||||
end;
|
||||
|
||||
gLog.AddTime('Game Load started');
|
||||
|
||||
//Resolutions are created first so that we could check Settings against them
|
||||
fResolutions := TKMResolutions.Create;
|
||||
|
||||
//Only after we read settings (fullscreen property and resolutions)
|
||||
//we can decide whenever we want to create Game fullscreen or not (OpenGL init depends on that)
|
||||
gGameAppSettings := TKMGameAppSettings.Create(Screen.Width, Screen.Height);
|
||||
|
||||
//We need to verify INI values, as they can be from another display
|
||||
if not fResolutions.IsValid(gMainSettings.Resolution) then
|
||||
begin
|
||||
gMainSettings.Resolution := fResolutions.FindCorrect(gMainSettings.Resolution);
|
||||
if not fResolutions.IsValid(gMainSettings.Resolution) then
|
||||
gMainSettings.FullScreen := False;
|
||||
end;
|
||||
|
||||
gVideoPlayer := TKMVideoPlayer.Create(FEAT_VIDEOS_UNDER_WINE or not IsUnderWine);
|
||||
|
||||
fFormMain.Caption := 'KaM Remake - ' + UnicodeString(GAME_VERSION);
|
||||
//Will make the form slightly higher, so do it before ReinitRender so it is reset
|
||||
fFormMain.UpdateFormState;
|
||||
|
||||
// Check INI window params, if not valid - set NeedResetToDefaults flag for future update
|
||||
if not gMainSettings.WindowParams.IsValid(GetScreenMonitorsInfo) then
|
||||
gMainSettings.WindowParams.NeedResetToDefaults := True;
|
||||
|
||||
// Stop app if we did not ReinitRender properly (didn't pass game folder permissions test)
|
||||
//todo -cComplicated: refactor. Separate folder permissions check and render initialization
|
||||
// Locale and texts could be loaded separetely to show proper translated error message
|
||||
if not ReinitRender(False) then
|
||||
Exit(False);
|
||||
|
||||
fFormMain.ControlsReset; // Reset controls will update Defaults.pas settings after loaded DevSettings
|
||||
fFormMain.ControlsRefill; // Refill some of the debug controls from game settings
|
||||
|
||||
// Create gSystem before Application.OnActivate (it uses FlashingStop)
|
||||
gSystem := TKMSystem.Create(fFormMain.Handle);
|
||||
|
||||
Application.OnIdle := DoIdle;
|
||||
Application.OnActivate := DoActivate;
|
||||
Application.OnDeactivate := DoDeactivate;
|
||||
Application.OnRestore := DoRestore; //OnActivate seems to happen at the wrong times, OnRestore happens when alt-tabbing back in full screen mode
|
||||
|
||||
//Update map cache files (*.mi) in the background so map lists load faster
|
||||
MapCacheUpdate;
|
||||
|
||||
//Process messages in queue before hiding Loading, so that they all land on Loading form, not main one
|
||||
Application.ProcessMessages;
|
||||
fFormLoading.Hide;
|
||||
|
||||
fFormMain.AfterFormCreated;
|
||||
|
||||
gLog.AddTime('Game Load Done in ' + IntToStr(TimeSince(time)));
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.HandleStatusBarText(aPanelIndex: TKMStatusBarPanel; aText: string);
|
||||
begin
|
||||
fFormMain.StatusBar1.Panels[Ord(aPanelIndex)].Text := aText;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.GameSpeedChange(aSpeed: Single);
|
||||
begin
|
||||
// Set check state without trigger OnClick event handler for the CheckBox
|
||||
fFormMain.chkSuperSpeed.SetCheckedWithoutClick(aSpeed = DEBUG_SPEEDUP_SPEED);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.CloseQuery(var aCanClose: Boolean);
|
||||
var
|
||||
wasRunning: Boolean;
|
||||
begin
|
||||
//MessageDlg works better than Application.MessageBox or others, it stays on top and
|
||||
//pauses here until the user clicks ok. However for some reason we chose MessageBox
|
||||
//thus we need to pause the game manually
|
||||
|
||||
aCanClose := (gGameApp = nil) or (gGameApp.Game = nil) or gGameApp.Game.Params.IsReplay;
|
||||
|
||||
if not aCanClose then
|
||||
begin
|
||||
//We want to pause the game for the time user verifies he really wants to close
|
||||
wasRunning := not gGameApp.Game.Params.IsMultiPlayerOrSpec
|
||||
and not gGameApp.Game.Params.IsMapEditor
|
||||
and not gGameApp.Game.IsPaused;
|
||||
|
||||
//Pause the game
|
||||
if wasRunning then
|
||||
gGameApp.Game.IsPaused := True;
|
||||
|
||||
//Ask the Player
|
||||
{$IF DEFINED(MSWindows)}
|
||||
//MessageBox works best in Windows (gets stuck under main form less)
|
||||
aCanClose := MessageBox( fFormMain.Handle,
|
||||
PChar(gResTexts[TX_EXIT_WARN_MESSAGE]),
|
||||
PChar(gResTexts[TX_EXIT_WARN_HEADER]),
|
||||
MB_YESNO or MB_ICONWARNING or MB_SETFOREGROUND or MB_TASKMODAL
|
||||
) = IDYES;
|
||||
{$ELSEIF DEFINED(Unix)}
|
||||
aCanClose := MessageDlg(gResTexts[TX_EXIT_WARN_MESSAGE], mtWarning, [mbYes, mbNo], 0) = mrYes;
|
||||
{$ELSE}
|
||||
{$ERROR Unsupported case. Please, implement the function}
|
||||
{$ENDIF}
|
||||
|
||||
//Resume the game
|
||||
if not aCanClose and wasRunning then
|
||||
gGameApp.Game.IsPaused := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.Stop(Sender: TObject);
|
||||
begin
|
||||
try
|
||||
gLog.AddTime('Stopping game application...');
|
||||
FreeThenNil(gSystem);
|
||||
//Reset the resolution
|
||||
FreeThenNil(fResolutions);
|
||||
|
||||
if fMapCacheUpdater <> nil then
|
||||
fMapCacheUpdater.Stop;
|
||||
|
||||
// Save Keys settings before destruction of gGameApp, since gResKeys, gResTexts, gResKeyFuncs are used when save to xml
|
||||
gKeySettings.SaveToXML;
|
||||
|
||||
FreeThenNil(gGameApp);
|
||||
// Destroy gGameAppSettings after GameApp is destroyed, since gGameSettings could be used during destruction
|
||||
FreeThenNil(gGameAppSettings);
|
||||
|
||||
FreeThenNil(gLog);
|
||||
|
||||
{$IFDEF MSWindows}
|
||||
TimeEndPeriod(1);
|
||||
ClipCursor(nil); //Release the cursor restriction
|
||||
{$ENDIF}
|
||||
|
||||
// We could have been asked to close by MainForm or from other place (e.g. MainMenu Exit button)
|
||||
// In first case Form will take care about closing itself
|
||||
|
||||
// Do not call gMain.Stop from FormClose handler again
|
||||
fFormMain.OnClose := nil;
|
||||
|
||||
if Assigned(gVideoPlayer) then
|
||||
gVideoPlayer.Free;
|
||||
|
||||
// fFormMain.DevSettingsSave; Moved into MainForm itself, since it's purely MainForms business. Rest of the app should know nothing about it
|
||||
|
||||
if Sender <> fFormMain then
|
||||
fFormMain.Close;
|
||||
except
|
||||
on E: Exception do
|
||||
gLog.AddTime('Exception while closing game app: ' + E.Message
|
||||
{$IFDEF WDC} + sLineBreak + E.StackTrace {$ENDIF});
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
//Apply the cursor restriction when alt-tabbing back
|
||||
procedure TKMMain.DoRestore(Sender: TObject);
|
||||
begin
|
||||
if Application.Active and (gMainSettings <> nil) then
|
||||
ApplyCursorRestriction; //Cursor restriction is lost when alt-tabbing out, so we need to apply it again
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.DoActivate(Sender: TObject);
|
||||
begin
|
||||
if Application.Active then
|
||||
gSystem.FlashingStop;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.DoDeactivate(Sender: TObject);
|
||||
begin
|
||||
//Occurs during Toggle to fullscreen, should be ignored
|
||||
if Application.Active then Exit;
|
||||
|
||||
//Prevent the game window from being in the way by minimizing when alt-tabbing
|
||||
if (gMainSettings <> nil) and gMainSettings.FullScreen then
|
||||
begin
|
||||
{$IFDEF MSWindows}
|
||||
ClipCursor(nil); //Remove all cursor clipping just in case Windows doesn't automatically
|
||||
{$ENDIF}
|
||||
Application.Minimize;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.UpdateFPS(latestFrameTime: Cardinal);
|
||||
var
|
||||
fpsLag: Integer;
|
||||
begin
|
||||
if gMainSettings <> nil then //gMainSettings could be nil on Game Exit ?? Just check if its not nil
|
||||
begin
|
||||
Inc(fOldFrameTimes, latestFrameTime);
|
||||
Inc(fFrameCount);
|
||||
if fOldFrameTimes >= FPS_INTERVAL then
|
||||
begin
|
||||
fFPS := 1000 / (fOldFrameTimes / fFrameCount);
|
||||
if gGameApp <> nil then
|
||||
gGameApp.SendFPSMeasurement(Round(fFPS));
|
||||
|
||||
fpsLag := 1000 div gMainSettings.FPSCap;
|
||||
fFPSString := Format('%.1f FPS', [fFPS]) + IfThen(CAP_MAX_FPS, ' (cap ' + IntToStr(fpsLag) + 'ms)');
|
||||
HandleStatusBarText(spFPS, fFPSString);
|
||||
fOldFrameTimes := 0;
|
||||
fFrameCount := 0;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMMain.GetRenderInterval: Cardinal;
|
||||
begin
|
||||
Result := 0;
|
||||
if CAP_MAX_FPS and (gMainSettings <> nil) then
|
||||
Result := 1000 div gMainSettings.FPSCap;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.DoRender;
|
||||
var renderDelta: Cardinal;
|
||||
begin
|
||||
renderDelta := TimeSince(fLastRenderTime);
|
||||
fLastRenderTime := TimeGet;
|
||||
UpdateFPS(renderDelta);
|
||||
|
||||
gGameApp.UpdateStateIdle(renderDelta);
|
||||
gGameApp.Render;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.SleepUntilNextSchedule;
|
||||
var
|
||||
nextTime, nextRender, nextTick, timeNow, sleepTime, renderInterval: Cardinal;
|
||||
begin
|
||||
renderInterval := GetRenderInterval;
|
||||
|
||||
nextRender := AddWithOverflow(fRenderSchedule, renderInterval);
|
||||
nextTick := AddWithOverflow(fTickSchedule, fGameTickInterval);
|
||||
|
||||
if nextRender > nextTick then
|
||||
nextTime := nextRender
|
||||
else
|
||||
nextTime := nextTick;
|
||||
|
||||
timeNow := TimeGet;
|
||||
if nextTime > timeNow then
|
||||
begin
|
||||
sleepTime := nextTime - timeNow;
|
||||
//Check for TimeGet overflow (never sleep longer than the render interval)
|
||||
if sleepTime < renderInterval then
|
||||
Sleep(sleepTime);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMMain.ForcedRenderRequired: Boolean;
|
||||
begin
|
||||
Result := (gMainSettings <> nil)
|
||||
and gMainSettings.IsNoRenderMaxTimeSet
|
||||
and (TimeSince(fLastRenderTime) > gMainSettings.NoRenderMaxTime);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.DoIdle(Sender: TObject; var Done: Boolean);
|
||||
|
||||
function CalculateSchedule(aLastTime, aTimeSince, aInterval: Cardinal): Cardinal;
|
||||
var
|
||||
ticksBehind: Cardinal;
|
||||
begin
|
||||
ticksBehind := (aTimeSince div aInterval);
|
||||
Result := AddWithOverflow(aLastTime, ticksBehind*aInterval);
|
||||
end;
|
||||
|
||||
const
|
||||
MAX_TIME_BETWEEN_RENDERS = 1000; //Render at least 1 FPS
|
||||
UI_UPDATE_INTERVAL = 100;
|
||||
var
|
||||
renderInterval, timeSinceRender, timeSinceTick, timeSinceUpdateUI: Cardinal;
|
||||
begin
|
||||
Done := False; //Repeats OnIdle asap without performing Form-specific idle code
|
||||
|
||||
if gGameApp = nil then
|
||||
begin
|
||||
Sleep(10);
|
||||
Exit;
|
||||
end;
|
||||
|
||||
if CHECK_8087CW then
|
||||
//$1F3F is used to mask out reserved/undefined bits
|
||||
Assert((Get8087CW and $1F3F = $133F), '8087CW is wrong');
|
||||
|
||||
//Some PCs seem to change 8087CW randomly between events like Timers and OnMouse*,
|
||||
//so we need to set it right before we do game logic processing
|
||||
Set8087CW($133F);
|
||||
|
||||
//Priority 1. Do we need to tick?
|
||||
timeSinceTick := TimeSince(fTickSchedule);
|
||||
if (timeSinceTick >= fGameTickInterval) and not ForcedRenderRequired then
|
||||
begin
|
||||
gGameApp.DoGameTick;
|
||||
fTickSchedule := CalculateSchedule(fTickSchedule, timeSinceTick, fGameTickInterval);
|
||||
end
|
||||
else
|
||||
begin
|
||||
//Priority 2. UI update and render
|
||||
timeSinceUpdateUI := TimeSince(fUpdateStateSchedule);
|
||||
if timeSinceUpdateUI >= UI_UPDATE_INTERVAL then
|
||||
begin
|
||||
gGameApp.UpdateState;
|
||||
fUpdateStateSchedule := CalculateSchedule(fUpdateStateSchedule, timeSinceUpdateUI, UI_UPDATE_INTERVAL);
|
||||
end;
|
||||
|
||||
renderInterval := GetRenderInterval;
|
||||
if renderInterval > 0 then
|
||||
begin
|
||||
timeSinceRender := TimeSince(fRenderSchedule);
|
||||
if timeSinceRender >= renderInterval then
|
||||
begin
|
||||
DoRender;
|
||||
fRenderSchedule := CalculateSchedule(fRenderSchedule, timeSinceRender, renderInterval);
|
||||
end
|
||||
else
|
||||
SleepUntilNextSchedule;
|
||||
end
|
||||
else
|
||||
DoRender; //No FPS cap so always render
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
// Check game execution dir generic permissions
|
||||
function TKMMain.DoHaveGenericPermission: Boolean;
|
||||
const
|
||||
GRANTED: array[Boolean] of string = ('blocked', 'granted');
|
||||
var
|
||||
readAcc, writeAcc, execAcc, dirWritable: Boolean;
|
||||
begin
|
||||
CheckFolderPermission(ExeDir, readAcc, writeAcc, execAcc);
|
||||
|
||||
dirWritable := IsDirectoryWriteable(ExeDir);
|
||||
|
||||
gLog.AddTime('Checking game folder "%s" generic permissions: READ: %s; WRITE: %s; EXECUTE: %s; folder is writable: %s',
|
||||
[ExeDir, GRANTED[readAcc], GRANTED[writeAcc], GRANTED[execAcc], BoolToStr(dirWritable, True)]);
|
||||
|
||||
Result := dirWritable and readAcc and writeAcc and execAcc;
|
||||
end;
|
||||
|
||||
|
||||
function TKMMain.ReinitRender(aReturnToOptions: Boolean): Boolean;
|
||||
|
||||
procedure ShowPermissionsError;
|
||||
begin
|
||||
SKIP_RENDER := True; // Skip render, since gGameApp will show panels on FullScreen mode
|
||||
fFormLoading.Hide; //Will close the form on Full Screen mode
|
||||
fFormMain.Hide;
|
||||
gMusic.Stop;
|
||||
fFormMain.ShowFolderPermissionError; // Show localized error message
|
||||
Stop(nil); // Stop the app
|
||||
end;
|
||||
|
||||
begin
|
||||
Result := True;
|
||||
if gMainSettings.FullScreen then
|
||||
begin
|
||||
// Lock window params while we are in FullScreen mode
|
||||
gMainSettings.WindowParams.LockParams;
|
||||
if fResolutions.IsValid(gMainSettings.Resolution) then
|
||||
fResolutions.SetResolution(gMainSettings.Resolution)
|
||||
else
|
||||
gMainSettings.FullScreen := False;
|
||||
end else
|
||||
fResolutions.Restore;
|
||||
|
||||
fFormLoading.Position := poScreenCenter;
|
||||
|
||||
// Will show windowed form and play videos
|
||||
// Should be made before GameApp creation, otherwise window position will not be set correctly
|
||||
// (its prbably because it will be overwritten, on gGameApp creation)
|
||||
if not gMainSettings.FullScreen then
|
||||
fFormMain.ShowInWindow;
|
||||
|
||||
//It's required to re-init whole OpenGL related things when RC gets toggled fullscreen
|
||||
FreeThenNil(gGameApp); //Saves all settings into ini file in midst
|
||||
gGameApp := TKMGameApp.Create(fFormMain.RenderArea,
|
||||
fFormMain.RenderArea.Width,
|
||||
fFormMain.RenderArea.Height,
|
||||
gMainSettings.VSync,
|
||||
fFormLoading.LoadingStep,
|
||||
fFormLoading.LoadingText,
|
||||
HandleStatusBarText);
|
||||
|
||||
// Will show fullscreen form and play videos
|
||||
// We need to start it after GameApp creation, since we need gResLocales to load proper video file by loaded locale
|
||||
if gMainSettings.FullScreen then
|
||||
fFormMain.ShowFullscreen;
|
||||
|
||||
// Check if player has all permissions on game folder. Close the app if not
|
||||
// Check is done after gGameApp creating because we want to load texts first to show traslated error message
|
||||
//todo -cComplicated: refactor. Separate folder permissions check and render initialization
|
||||
// Locale and texts could be loaded separetely to show proper translated error message
|
||||
try
|
||||
if (gLog = nil)
|
||||
or (not aReturnToOptions and not DoHaveGenericPermission) then
|
||||
begin
|
||||
ShowPermissionsError;
|
||||
Exit(False); // Stop the app
|
||||
end;
|
||||
except
|
||||
// but it seems like Exit alone doesn't work - try-except block does
|
||||
ShowPermissionsError;
|
||||
Exit(False); // Stop the app
|
||||
end;
|
||||
|
||||
gGameApp.OnGameSpeedActualChange := GameSpeedChange;
|
||||
gGameApp.AfterConstruction(aReturnToOptions);
|
||||
|
||||
//Preload game resources while in menu to make 1st game start faster
|
||||
gGameApp.PreloadGameResources;
|
||||
|
||||
gGameApp.OnOptionsChange := fFormMain.ControlsRefill;
|
||||
fFormMain.OnControlsUpdated := gGameApp.DebugControlsUpdated;
|
||||
|
||||
gLog.AddTime('ToggleFullscreen');
|
||||
gLog.AddTime('Form Width/Height: %dx%d', [fFormMain.Width, fFormMain.Height]);
|
||||
gLog.AddTime('Panel Width/Height: %dx%d', [fFormMain.RenderArea.Width, fFormMain.RenderArea.Height]);
|
||||
|
||||
//Hide'n'show will make form go ontop of taskbar
|
||||
fFormMain.Hide;
|
||||
fFormMain.Show;
|
||||
|
||||
ForceResize; //Force everything to resize
|
||||
|
||||
// Unlock window params if are no longer in FullScreen mode
|
||||
if not gMainSettings.FullScreen then
|
||||
gMainSettings.WindowParams.UnlockParams;
|
||||
|
||||
ApplyCursorRestriction;
|
||||
end;
|
||||
|
||||
|
||||
function TKMMain.LockMutex: Boolean;
|
||||
begin
|
||||
Result := True;
|
||||
{$IFDEF MSWindows}
|
||||
if not BLOCK_DUPLICATE_APP then Exit;
|
||||
|
||||
fMutex := CreateMutex(nil, True, PChar(KAM_MUTEX));
|
||||
|
||||
if fMutex = 0 then
|
||||
RaiseLastOSError;
|
||||
|
||||
Result := (GetLastError <> ERROR_ALREADY_EXISTS);
|
||||
|
||||
if not Result then
|
||||
// Close our own handle on the mutex because someone else already made the mutex
|
||||
UnlockMutex;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.UnlockMutex;
|
||||
begin
|
||||
{$IFDEF MSWindows}
|
||||
if not BLOCK_DUPLICATE_APP then Exit;
|
||||
if fMutex = 0 then Exit; //Didn't have a mutex lock
|
||||
CloseHandle(fMutex);
|
||||
fMutex := 0;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.MapCacheUpdate;
|
||||
begin
|
||||
// Thread frees itself automatically
|
||||
fMapCacheUpdater := TTMapsCacheUpdater.Create([mkSP, mkMP, mkDL]);
|
||||
end;
|
||||
|
||||
|
||||
function TKMMain.IsDebugChangeAllowed: Boolean;
|
||||
begin
|
||||
Result := (gGameApp.Game = nil)
|
||||
or not gGameApp.Game.Params.IsMultiPlayerOrSpec
|
||||
or MULTIPLAYER_CHEATS;
|
||||
end;
|
||||
|
||||
|
||||
function TKMMain.ClientRect(aPixelsCntToReduce: Integer = 0): TRect;
|
||||
begin
|
||||
Result := fFormMain.RenderArea.ClientRect;
|
||||
Result.TopLeft := ClientToScreen(Result.TopLeft);
|
||||
Result.TopLeft.X := Result.TopLeft.X + aPixelsCntToReduce;
|
||||
Result.TopLeft.Y := Result.TopLeft.Y + aPixelsCntToReduce;
|
||||
Result.BottomRight := ClientToScreen(Result.BottomRight);
|
||||
Result.BottomRight.X := Result.BottomRight.X - aPixelsCntToReduce;
|
||||
Result.BottomRight.Y := Result.BottomRight.Y - aPixelsCntToReduce;
|
||||
end;
|
||||
|
||||
|
||||
function TKMMain.ClientToScreen(aPoint: TPoint): TPoint;
|
||||
begin
|
||||
Result := fFormMain.RenderArea.ClientToScreen(aPoint);
|
||||
end;
|
||||
|
||||
|
||||
//Can be invalid very breifly if you change resolutions (this is possible in Windowed mode)
|
||||
function TKMMain.GetScreenBounds(out aBounds: TRect): Boolean;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
try
|
||||
aBounds := Classes.Rect(-1,-1,-1,-1);
|
||||
fFormMain.Monitor; //This forces Delphi to reload Screen.Monitors (only if necessary) and so fixes crashes when using multiple monitors
|
||||
//Maximized is a special case, it can only be on one monitor. This is required because when maximized form.left = -9 (on Windows 7 anyway)
|
||||
if fFormMain.WindowState = wsMaximized then
|
||||
begin
|
||||
for I := 0 to Screen.MonitorCount-1 do
|
||||
//Find the monitor with the left closest to the left of the form
|
||||
if (I = 0)
|
||||
or ((Abs(fFormMain.Left - Screen.Monitors[I].Left) <= Abs(fFormMain.Left - aBounds.Left)) and
|
||||
(Abs(fFormMain.Top - Screen.Monitors[I].Top ) <= Abs(fFormMain.Top - aBounds.Top))) then
|
||||
begin
|
||||
Result := True;
|
||||
aBounds.Left := Screen.Monitors[I].Left;
|
||||
aBounds.Right := Screen.Monitors[I].Width+Screen.Monitors[I].Left;
|
||||
aBounds.Top := Screen.Monitors[I].Top;
|
||||
aBounds.Bottom:= Screen.Monitors[I].Height+Screen.Monitors[I].Top;
|
||||
end;
|
||||
end
|
||||
else
|
||||
for I:=0 to Screen.MonitorCount-1 do
|
||||
//See if our form is within the boundaries of this monitor (I.e. when it is not outside the boundaries)
|
||||
if not ((fFormMain.Left >= Screen.Monitors[I].Width + Screen.Monitors[I].Left) or
|
||||
(fFormMain.Width + fFormMain.Left <= Screen.Monitors[I].Left) or
|
||||
(fFormMain.Top >= Screen.Monitors[I].Height + Screen.Monitors[I].Top) or
|
||||
(fFormMain.Height + fFormMain.Top <= Screen.Monitors[I].Top)) then
|
||||
begin
|
||||
if not Result then
|
||||
begin
|
||||
//First time we have to initialise the result
|
||||
Result := True;
|
||||
aBounds.Left := Screen.Monitors[I].Left;
|
||||
aBounds.Right := Screen.Monitors[I].Width+Screen.Monitors[I].Left;
|
||||
aBounds.Top := Screen.Monitors[I].Top;
|
||||
aBounds.Bottom:= Screen.Monitors[I].Height+Screen.Monitors[I].Top;
|
||||
end
|
||||
else
|
||||
begin
|
||||
//After the first time we compare it with the previous result and take the largest possible area
|
||||
aBounds.Left := Math.Min(aBounds.Left, Screen.Monitors[I].Left);
|
||||
aBounds.Right := Math.Max(aBounds.Right, Screen.Monitors[I].Width+Screen.Monitors[I].Left);
|
||||
aBounds.Top := Math.Min(aBounds.Top, Screen.Monitors[I].Top);
|
||||
aBounds.Bottom:= Math.Max(aBounds.Bottom,Screen.Monitors[I].Height+Screen.Monitors[I].Top);
|
||||
end;
|
||||
end;
|
||||
except
|
||||
on E: Exception do
|
||||
gLog.AddTime('Exception in TKMMain.GetScreenBounds: ' + E.Message
|
||||
{$IFDEF WDC} + sLineBreak + E.StackTrace {$ENDIF});
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMMain.IsFormActive: Boolean;
|
||||
begin
|
||||
Result := fFormMain.Active;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.Render;
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
|
||||
gGameApp.Render;
|
||||
end;
|
||||
|
||||
|
||||
//Force everything to resize
|
||||
procedure TKMMain.ForceResize;
|
||||
begin
|
||||
Resize(fFormMain.RenderArea.Width, fFormMain.RenderArea.Height);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.Resize(aWidth, aHeight: Integer);
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
|
||||
gGameApp.Resize(aWidth, aHeight);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.Resize(aWidth, aHeight: Integer; const aWindowParams: TKMWindowParamsRecord);
|
||||
begin
|
||||
if gGameApp = nil then Exit;
|
||||
|
||||
gGameApp.Resize(aWidth, aHeight);
|
||||
UpdateWindowParams(aWindowParams);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.Move(const aWindowParams: TKMWindowParamsRecord);
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
|
||||
UpdateWindowParams(aWindowParams);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.UpdateWindowParams(const aWindowParams: TKMWindowParamsRecord);
|
||||
begin
|
||||
if gGameApp = nil then Exit;
|
||||
if gMainSettings.WindowParams = nil then Exit; //just in case...
|
||||
|
||||
gMainSettings.WindowParams.ApplyWindowParams(aWindowParams);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.SetGameTickInterval(aInterval: Cardinal);
|
||||
begin
|
||||
if Self = nil then Exit; // Could be nil in Runner
|
||||
|
||||
fGameTickInterval := aInterval;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMain.ShowAbout;
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
|
||||
fFormLoading.Position := poScreenCenter;
|
||||
fFormLoading.Bar1.Position := 0;
|
||||
fFormLoading.Label1.Caption := '';
|
||||
fFormLoading.FormStyle := fsStayOnTop;
|
||||
fFormLoading.Show;
|
||||
end;
|
||||
|
||||
|
||||
//Restrict cursor movement in fullscreen mode
|
||||
//For multiple monitors, it's very annoying if you play a fullscreen game and your cursor slides
|
||||
//onto second monitor instead of stopping at the edge as expected.
|
||||
procedure TKMMain.ApplyCursorRestriction;
|
||||
var
|
||||
rect: TRect;
|
||||
begin
|
||||
//This restriction is removed when alt-tabbing out, and added again when alt-tabbing back
|
||||
{$IFDEF MSWindows}
|
||||
if gMainSettings.FullScreen then
|
||||
begin
|
||||
rect := fFormMain.BoundsRect;
|
||||
ClipCursor(@rect);
|
||||
end
|
||||
else
|
||||
ClipCursor(nil); //Otherwise have no restriction
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
+489
@@ -0,0 +1,489 @@
|
||||
unit KM_Projectiles;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
KM_Units, KM_Houses,
|
||||
KM_CommonClasses, KM_CommonGameTypes, KM_Points, KM_RenderTypes;
|
||||
|
||||
|
||||
type
|
||||
// Projectiles in-game: arrows, bolts, rocks, etc..
|
||||
// Once launched they are on their own
|
||||
TKMProjectiles = class
|
||||
private
|
||||
fItems: array of record //1..n
|
||||
fScreenStart: TKMPointF; //Screen-space trajectory start
|
||||
fScreenEnd: TKMPointF; //Screen-space trajectory end
|
||||
|
||||
fAim: TKMPointF; //Where we were aiming to hit
|
||||
fTarget: TKMPointF; //Where projectile will hit
|
||||
fShotFrom: TKMPointF; //Where the projectile was launched from
|
||||
|
||||
fType: TKMProjectileType; //type of projectile (arrow, bolt, rocks, etc..)
|
||||
fOwner: TKMUnit; //The projectiles owner, used for kill statistics and script events
|
||||
fSpeed: Single; //Each projectile speed may vary a little bit
|
||||
fArc: Single; //Thats how high projectile will go along parabola (varies a little more)
|
||||
fPosition: Single; //Projectiles position along the route Start>>End
|
||||
fLength: Single; //Route length to look-up for hit
|
||||
fMaxLength: Single; //Maximum length the archer could have shot
|
||||
end;
|
||||
|
||||
fOnAddProjectileToRenderPool: TKMRenderPoolAddProjectileEvent;
|
||||
|
||||
function AddItem(const aStart,aAim,aEnd: TKMPointF; aSpeed, aArc, aMaxLength: Single; aProjType: TKMProjectileType; aOwner: TKMUnit): Word;
|
||||
procedure RemItem(aIndex: Integer);
|
||||
function ProjectileVisible(aIndex: Integer): Boolean;
|
||||
procedure AddProjectileToRenderPool(aProj: TKMProjectileType; const aRenderPos, aTilePos: TKMPointF; aDir: TKMDirection; aFlight: Single); inline;
|
||||
public
|
||||
constructor Create(aOnAddProjectileToRenderPool: TKMRenderPoolAddProjectileEvent);
|
||||
|
||||
function AimTargetUnit(const aStart: TKMPointF; aTarget: TKMUnit; aProjType: TKMProjectileType; aOwner: TKMUnit; aMaxRange, aMinRange: Single): Word;
|
||||
function AimTargetHouse(const aStart: TKMPointF; aTarget: TKMHouse; aProjType: TKMProjectileType; aOwner: TKMUnit; aMaxRange, aMinRange: Single): Word;
|
||||
|
||||
procedure UpdateState;
|
||||
procedure Paint(aTickLag: Single);
|
||||
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure Load(LoadStream: TKMemoryStream);
|
||||
procedure SyncLoad;
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
gProjectiles: TKMProjectiles;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Math, KromUtils,
|
||||
KM_Entity,
|
||||
KM_Terrain, KM_RenderAux,
|
||||
KM_Resource, KM_ResSound, KM_ResUnits,
|
||||
KM_Hand, KM_HandsCollection, KM_HandTypes, KM_HandEntity,
|
||||
KM_Sound,
|
||||
KM_CommonUtils, KM_Defaults;
|
||||
|
||||
|
||||
const
|
||||
PROJECTILE_LAUNCH_SOUND: array[TKMProjectileType] of TKMSoundEffectOriginal = (sfxBowShoot, sfxCrossbowShoot, sfxNone, sfxRockThrow);
|
||||
PROJECTILE_HIT_SOUND: array[TKMProjectileType] of TKMSoundEffectOriginal = (sfxArrowHit, sfxArrowHit, sfxArrowHit, sfxNone);
|
||||
PROJECTILE_SPEED: array[TKMProjectileType] of Single = (0.75, 0.75, 0.6, 0.8);
|
||||
PROJECTILE_ARC: array[TKMProjectileType,1..2] of Single = ((1.6, 0.5), (1.4, 0.4), (2.5, 1), (1.2, 0.2)); //Arc curve and random fraction
|
||||
PROJECTILE_JITTER: array[TKMProjectileType] of Single = (0.26, 0.29, 0.26, 0.2); //Fixed Jitter added every time
|
||||
PROJECTILE_JITTER_HOUSE: array[TKMProjectileType] of Single = (0.6, 0.6, 0.6, 0); //Fixed Jitter added every time
|
||||
// Jitter added according to target's speed (moving target harder to hit) Note: Walking = 0.1, so the added jitter is 0.1*X
|
||||
PROJECTILE_PREDICT_JITTER: array[TKMProjectileType] of Single = (2, 2, 2, 3);
|
||||
|
||||
|
||||
{ TKMProjectiles }
|
||||
constructor TKMProjectiles.Create(aOnAddProjectileToRenderPool: TKMRenderPoolAddProjectileEvent);
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
fOnAddProjectileToRenderPool := aOnAddProjectileToRenderPool;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMProjectiles.RemItem(aIndex: Integer);
|
||||
begin
|
||||
gHands.CleanUpUnitPointer(fItems[aIndex].fOwner);
|
||||
fItems[aIndex].fSpeed := 0;
|
||||
end;
|
||||
|
||||
|
||||
function TKMProjectiles.AimTargetUnit(const aStart: TKMPointF; aTarget: TKMUnit; aProjType: TKMProjectileType; aOwner: TKMUnit; aMaxRange, aMinRange: Single): Word;
|
||||
var
|
||||
targetVector, target, targetPosition: TKMPointF;
|
||||
A,B,C,D: Single;
|
||||
timeToHit, time1, time2, distanceToHit, distanceInRange: Single;
|
||||
jitter, speed, arc: Single;
|
||||
U: TKMUnit;
|
||||
begin
|
||||
//Now we know projectiles speed and aim, we can predict where target will be at the time projectile hits it
|
||||
|
||||
//I wonder if medieval archers knew about vectors and quadratic equations
|
||||
|
||||
targetPosition.X := (aTarget.PositionF.X - aStart.X);
|
||||
targetPosition.Y := (aTarget.PositionF.Y - aStart.Y);
|
||||
targetVector := aTarget.GetMovementVector;
|
||||
|
||||
{ This comment explains how we came to final ABC equation
|
||||
|
||||
Target = TargetPosition + TargetVector * Time;
|
||||
FlightDistance := ArrowSpeed * Time;
|
||||
|
||||
sqr(Target) = sqr(FlightDistance);
|
||||
|
||||
sqr(TargetPosition + TargetVector * Time) = sqr(ArrowSpeed * Time)
|
||||
|
||||
sqr(TargetPosition.X) + 2 * Time * TargetPosition.X * TargetVector.X + sqr(Time) * sqr(TargetVector.X) +
|
||||
sqr(ArrowSpeed) * sqr(Time)
|
||||
|
||||
sqr(Time) * (sqr(TargetVector.X) + sqr(TargetVector.Y) - sqr(ArrowSpeed)) +
|
||||
2 * Time * (TargetPosition.X * TargetVector.X + TargetPosition.Y * TargetVector.Y) +
|
||||
sqr(TargetPosition.X) + sqr(TargetPosition.Y) = 0
|
||||
|
||||
//Lets try to solve this quadratic equation
|
||||
//ATT + BT + C = 0
|
||||
//by using formulae X = (-B +- sqrt(B*B - 4*A*C)) / 2*A
|
||||
A = sqr(TargetVector.X) + sqr(TargetVector.Y) - sqr(ArrowSpeed)
|
||||
B = 2 * (TargetPosition.X * TargetVector.X + TargetPosition.Y * TargetVector.Y)
|
||||
C = sqr(TargetPosition.X) + sqr(TargetPosition.Y) }
|
||||
|
||||
speed := PROJECTILE_SPEED[aProjType] + KaMRandomS2(0.05{$IFDEF DBG_RNG_SPY}, 'TKMProjectiles.AimTarget'{$ENDIF});
|
||||
|
||||
A := sqr(targetVector.X) + sqr(targetVector.Y) - sqr(speed);
|
||||
B := 2 * (targetPosition.X * targetVector.X + targetPosition.Y * targetVector.Y);
|
||||
C := sqr(targetPosition.X) + sqr(targetPosition.Y);
|
||||
|
||||
D := sqr(B) - 4 * A * C;
|
||||
|
||||
if (D >= 0) and (A <> 0) then
|
||||
begin
|
||||
time1 := (-B + sqrt(D)) / (2 * A);
|
||||
time2 := (-B - sqrt(D)) / (2 * A);
|
||||
|
||||
//Choose smallest positive time
|
||||
if (time1 > 0) and (time2 > 0) then
|
||||
timeToHit := Math.min(time1, time2)
|
||||
else
|
||||
if (time1 < 0) and (time2 < 0) then
|
||||
timeToHit := 0
|
||||
else
|
||||
timeToHit := Math.max(time1, time2);
|
||||
end
|
||||
else
|
||||
timeToHit := 0;
|
||||
|
||||
if timeToHit <> 0 then
|
||||
begin
|
||||
jitter := PROJECTILE_JITTER[aProjType]
|
||||
+ KMLength(KMPOINTF_ZERO, targetVector) * PROJECTILE_PREDICT_JITTER[aProjType];
|
||||
|
||||
//Calculate the target position relative to start position (the 0;0)
|
||||
target.X := targetPosition.X + targetVector.X*timeToHit + KaMRandomS2(jitter{$IFDEF DBG_RNG_SPY}, 'TKMProjectiles.AimTarget 2'{$ENDIF});
|
||||
target.Y := targetPosition.Y + targetVector.Y*timeToHit + KaMRandomS2(jitter{$IFDEF DBG_RNG_SPY}, 'TKMProjectiles.AimTarget 3'{$ENDIF});
|
||||
|
||||
//We can try and shoot at a target that is moving away,
|
||||
//but the arrows can't flight any further than their max_range
|
||||
distanceToHit := GetLength(target.X, target.Y);
|
||||
distanceInRange := EnsureRange(distanceToHit, aMinRange, aMaxRange);
|
||||
target.X := aStart.X + target.X / distanceToHit * distanceInRange;
|
||||
target.Y := aStart.Y + target.Y / distanceToHit * distanceInRange;
|
||||
|
||||
//Calculate the arc, less for shorter flights
|
||||
arc := ((distanceInRange-aMinRange)/(aMaxRange-aMinRange))*(PROJECTILE_ARC[aProjType, 1] + KaMRandomS2(PROJECTILE_ARC[aProjType, 2]{$IFDEF DBG_RNG_SPY}, 'TKMProjectiles.AimTarget 4'{$ENDIF}));
|
||||
|
||||
//Check whether this predicted target will hit a friendly unit
|
||||
if gTerrain.TileInMapCoords(Round(target.X), Round(target.Y)) then //Arrows may fly off map, UnitsHitTest doesn't like negative coordinates
|
||||
begin
|
||||
U := gTerrain.UnitsHitTest(Round(target.X), Round(target.Y));
|
||||
if (U <> nil) and (gHands.CheckAlliance(aOwner.Owner, U.Owner) = atAlly) then
|
||||
target := aTarget.PositionF; //Shoot at the target's current position instead
|
||||
end;
|
||||
|
||||
Result := AddItem(aStart, aTarget.PositionF, target, speed, arc, aMaxRange, aProjType, aOwner);
|
||||
|
||||
//Tell the Opponent that he is under attack (when arrows are in the air)
|
||||
gHands[aTarget.Owner].AI.UnitAttackNotification(aTarget, aOwner);
|
||||
end else
|
||||
Result := 0;
|
||||
end;
|
||||
|
||||
|
||||
function TKMProjectiles.AimTargetHouse(const aStart: TKMPointF; aTarget: TKMHouse; aProjType: TKMProjectileType; aOwner: TKMUnit; aMaxRange, aMinRange: Single): Word;
|
||||
var
|
||||
speed, arc: Single;
|
||||
distanceToHit, distanceInRange: Single;
|
||||
aim, target: TKMPointF;
|
||||
begin
|
||||
speed := PROJECTILE_SPEED[aProjType] + KaMRandomS2(0.05{$IFDEF DBG_RNG_SPY}, 'TKMProjectiles.AimTarget 5'{$ENDIF});
|
||||
|
||||
aim := KMPointF(aTarget.GetRandomCellWithin);
|
||||
target.X := aim.X + KaMRandomS2(PROJECTILE_JITTER_HOUSE[aProjType]{$IFDEF DBG_RNG_SPY}, 'TKMProjectiles.AimTarget 6'{$ENDIF}); //So that arrows were within house area, without attitude to tile corners
|
||||
target.Y := aim.Y + KaMRandomS2(PROJECTILE_JITTER_HOUSE[aProjType]{$IFDEF DBG_RNG_SPY}, 'TKMProjectiles.AimTarget 7'{$ENDIF});
|
||||
|
||||
//Calculate the arc, less for shorter flights
|
||||
distanceToHit := GetLength(aStart.X - target.X, aStart.Y - target.Y);
|
||||
distanceInRange := EnsureRange(distanceToHit, aMinRange, aMaxRange);
|
||||
|
||||
var arcRandom := KaMRandomS2(PROJECTILE_ARC[aProjType, 2]{$IFDEF DBG_RNG_SPY}, 'TKMProjectiles.AimTarget 8'{$ENDIF});
|
||||
arc := Math.Max((distanceInRange - aMinRange) / (aMaxRange - aMinRange) * PROJECTILE_ARC[aProjType, 1] + arcRandom, 0);
|
||||
|
||||
Result := AddItem(aStart, aim, target, speed, arc, aMaxRange, aProjType, aOwner);
|
||||
end;
|
||||
|
||||
|
||||
// Return flight time (archers like to know when they hit target before firing again)
|
||||
function TKMProjectiles.AddItem(const aStart, aAim, aEnd: TKMPointF; aSpeed, aArc, aMaxLength: Single; aProjType: TKMProjectileType; aOwner: TKMUnit): Word;
|
||||
const
|
||||
// TowerRock position is a bit different for reasons said below
|
||||
// Recruit stands in entrance, Tower middleline is X-0.75
|
||||
OFFSET_X: array [TKMDirection] of array [TKMProjectileType] of Single =
|
||||
((0.5, 0.5, 0.5, -0.25), // dirNA
|
||||
(0.5, 0.5, 0.7, -0.25), // dirN
|
||||
(1.0, 0.5, 0.7, -0.25), // dirNE
|
||||
(0.7, 0.5, 0.7, -0.25), // dirE
|
||||
(0.7, 0.5, 0.7, -0.25), // dirSE
|
||||
(0.4, 0.4, 0.3, -0.25), // dirS
|
||||
(0.4, 0.4, 0.5, -0.25), // dirSW
|
||||
(0.4, 0.4, 0.5, -0.25), // dirW
|
||||
(0.3, 0.5, 0.5, -0.25)); // dirNW
|
||||
// Add towers height
|
||||
OFFSET_Y: array [TKMDirection] of array [TKMProjectileType] of Single =
|
||||
((0.2, 0.2, 0.2, -0.2), // dirNA
|
||||
(0.2, 0.2, 0.2, -0.2), // dirN
|
||||
(0.0, 0.6, 0.5, -0.2), // dirNE
|
||||
(0.3, 0.35,0.3, -0.2), // dirE
|
||||
(0.5, 0.4, 0.5, -0.2), // dirSE
|
||||
(0.3, 0.2, 0.4, -0.2), // dirS
|
||||
(0.4, 0.4, 0.2, -0.2), // dirSW
|
||||
(0.2, 0.3, 0.3, -0.2), // dirW
|
||||
(0.1, 0.3, 0.3, -0.2)); // dirNW
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
I := -1;
|
||||
repeat
|
||||
Inc(I);
|
||||
if I >= Length(fItems) then
|
||||
SetLength(fItems, I+8); //Add new
|
||||
until(fItems[I].fSpeed = 0);
|
||||
|
||||
//Fill in basic info
|
||||
fItems[I].fType := aProjType;
|
||||
fItems[I].fSpeed := aSpeed;
|
||||
fItems[I].fArc := aArc;
|
||||
fItems[I].fOwner := aOwner.GetPointer;
|
||||
fItems[I].fAim := aAim;
|
||||
//Don't allow projectile to land off map, (we use fTaret for hit tests, FOW, etc.) but on borders is fine
|
||||
fItems[I].fTarget.X := EnsureRange(aEnd.X, 0, gTerrain.MapX-0.01);
|
||||
fItems[I].fTarget.Y := EnsureRange(aEnd.Y, 0, gTerrain.MapY-0.01);
|
||||
fItems[I].fShotFrom := aStart;
|
||||
|
||||
fItems[I].fScreenStart.X := aStart.X + OFFSET_X[aOwner.Direction, aProjType];
|
||||
fItems[I].fScreenStart.Y := gTerrain.FlatToHeight(aStart).Y + OFFSET_Y[aOwner.Direction, aProjType];
|
||||
fItems[I].fScreenEnd.X := fItems[I].fTarget.X + 0.5; //projectile hits on Unit's chest height
|
||||
fItems[I].fScreenEnd.Y := gTerrain.FlatToHeight(fItems[I].fTarget).Y + 0.5;
|
||||
|
||||
fItems[I].fPosition := 0; //projectile position on its route
|
||||
fItems[I].fLength := KMLength(fItems[I].fScreenStart, fItems[I].fScreenEnd); //route length
|
||||
fItems[I].fMaxLength:= aMaxLength;
|
||||
|
||||
if (gMySpectator.FogOfWar.CheckTileRevelation(KMPointRound(aStart).X, KMPointRound(aStart).Y) >= 255) then
|
||||
gSoundPlayer.Play(PROJECTILE_LAUNCH_SOUND[aProjType], aStart);
|
||||
|
||||
Result := Round(fItems[I].fLength / fItems[I].fSpeed);
|
||||
end;
|
||||
|
||||
|
||||
//Update all items positions and kill some targets
|
||||
procedure TKMProjectiles.UpdateState;
|
||||
const
|
||||
H_TICKS = 6; //The number of ticks before hitting that an arrow will make the hit noise
|
||||
var
|
||||
I: Integer;
|
||||
U: TKMUnit;
|
||||
H: TKMHouse;
|
||||
Damage: Smallint;
|
||||
begin
|
||||
for I := 0 to Length(fItems) - 1 do
|
||||
with fItems[I] do
|
||||
if fSpeed <> 0 then
|
||||
begin
|
||||
fPosition := fPosition + fSpeed;
|
||||
|
||||
//Will hit the target in X..X-1 ticks (this ensures it only happens once)
|
||||
//Can't use InRange cos it might get called twice due to <= X <= comparison
|
||||
if gMySpectator.FogOfWar.CheckRevelation(fTarget) >= 255 then
|
||||
if (fLength - H_TICKS*fSpeed <= fPosition) and (fPosition < fLength - (H_TICKS - 1) * fSpeed) then
|
||||
gSoundPlayer.Play(PROJECTILE_HIT_SOUND[fType], fTarget);
|
||||
|
||||
if fPosition >= fLength then
|
||||
begin
|
||||
U := gTerrain.UnitsHitTestF(fTarget);
|
||||
//Projectile can miss depending on the distance to the unit
|
||||
if (U = nil) or ((1 - Math.Min(KMLength(U.PositionF, fTarget), 1)) > KaMRandom({$IFDEF DBG_RNG_SPY}'TKMProjectiles.UpdateState'{$ENDIF})) then
|
||||
begin
|
||||
case fType of
|
||||
ptArrow,
|
||||
ptSlingRock,
|
||||
ptBolt: if (U <> nil) and not U.IsDeadOrDying and U.Visible and not (U is TKMUnitAnimal)
|
||||
//Can't hit units past max range because that's unintuitive/confusing to player
|
||||
and (KMLengthSqr(fShotFrom, U.PositionF) <= Sqr(fMaxLength)) then
|
||||
begin
|
||||
Damage := 0;
|
||||
if fType = ptArrow then Damage := gRes.Units[utBowman].Attack;
|
||||
if fType = ptBolt then Damage := gRes.Units[utCrossbowman].Attack;
|
||||
if fType = ptSlingRock then Damage := gRes.Units[utRogue].Attack;
|
||||
Damage := Round(Damage / Math.max(gRes.Units[U.UnitType].GetDefenceVsProjectiles(fType = ptBolt), 1)); //Max is not needed, but animals have 0 defence
|
||||
if (FRIENDLY_FIRE or (gHands.CheckAlliance(fOwner.Owner, U.Owner)= atEnemy))
|
||||
and (Damage >= KaMRandom(101{$IFDEF DBG_RNG_SPY}, 'TKMProjectiles.UpdateState'{$ENDIF})) then
|
||||
U.HitPointsDecrease(1, fOwner);
|
||||
end
|
||||
else
|
||||
begin
|
||||
H := gHands.HousesHitTest(Round(fTarget.X), Round(fTarget.Y));
|
||||
if (H <> nil)
|
||||
and (FRIENDLY_FIRE or (gHands.CheckAlliance(fOwner.Owner, H.Owner)= atEnemy))
|
||||
then
|
||||
H.AddDamage(1, fOwner);
|
||||
end;
|
||||
ptTowerRock: if (U <> nil) and not U.IsDeadOrDying and U.Visible
|
||||
and not (U is TKMUnitAnimal)
|
||||
and (FRIENDLY_FIRE or (gHands.CheckAlliance(fOwner.Owner, U.Owner)= atEnemy)) then
|
||||
U.HitPointsDecrease(U.HitPointsMax, fOwner); //Instant death
|
||||
end;
|
||||
end;
|
||||
RemItem(I);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMProjectiles.AddProjectileToRenderPool(aProj: TKMProjectileType; const aRenderPos, aTilePos: TKMPointF; aDir: TKMDirection; aFlight: Single);
|
||||
begin
|
||||
if Assigned(fOnAddProjectileToRenderPool) then
|
||||
fOnAddProjectileToRenderPool(aProj, aRenderPos, aTilePos, aDir, aFlight);
|
||||
end;
|
||||
|
||||
|
||||
//Test wherever projectile is visible (used by rocks thrown from Towers)
|
||||
function TKMProjectiles.ProjectileVisible(aIndex: Integer): Boolean;
|
||||
begin
|
||||
if (fItems[aIndex].fType = ptTowerRock)
|
||||
and ((fItems[aIndex].fScreenEnd.Y - fItems[aIndex].fScreenStart.Y) < 0) then
|
||||
Result := fItems[aIndex].fPosition >= 0.2 //fly behind a Tower
|
||||
else
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMProjectiles.Paint(aTickLag: Single);
|
||||
var
|
||||
I: Integer;
|
||||
mixValue, mixValueMax, tickLagOffset, laggedPosition: Single;
|
||||
mixArc: Single; //mix Arc shape
|
||||
P: TKMPointF; //Arrows and bolts send 2 points for head and tail
|
||||
pTileBased: TKMPointF;
|
||||
dir: TKMDirection;
|
||||
begin
|
||||
for I := 0 to Length(fItems) - 1 do
|
||||
if (fItems[I].fSpeed <> 0) and ProjectileVisible(I) then
|
||||
begin
|
||||
tickLagOffset := aTickLag*fItems[I].fSpeed;
|
||||
laggedPosition := fItems[I].fPosition - tickLagOffset;
|
||||
//If the projectile hasn't appeared yet in lagged time
|
||||
if laggedPosition < 0 then Continue;
|
||||
|
||||
mixValue := EnsureRange(laggedPosition / fItems[I].fLength, 0.0, 1.0); // 0 >> 1
|
||||
mixValueMax := EnsureRange(laggedPosition / fItems[I].fMaxLength, 0.0, 1.0); // 0 >> 1
|
||||
P := KMLerp(fItems[I].fScreenStart, fItems[I].fScreenEnd, mixValue);
|
||||
pTileBased := KMLerp(fItems[I].fShotFrom, fItems[I].fTarget, mixValue);
|
||||
case fItems[I].fType of
|
||||
ptArrow, ptSlingRock, ptBolt:
|
||||
begin
|
||||
mixArc := sin(mixValue*pi); // 0 >> 1 >> 0 Parabola
|
||||
//Looks better moved up, launches from the bow not feet and lands in target's body
|
||||
P.Y := P.Y - fItems[I].fArc * mixArc - 0.4;
|
||||
dir := KMGetDirection(fItems[I].fScreenStart, fItems[I].fScreenEnd);
|
||||
AddProjectileToRenderPool(fItems[I].fType, P, pTileBased, dir, mixValueMax);
|
||||
end;
|
||||
|
||||
ptTowerRock:
|
||||
begin
|
||||
mixArc := cos(mixValue*pi/2); // 1 >> 0 Half-parabola
|
||||
//Looks better moved up, lands on the target's body not at his feet
|
||||
P.Y := P.Y - fItems[I].fArc * mixArc - 0.4;
|
||||
AddProjectileToRenderPool(fItems[I].fType, P, pTileBased, dirN, mixValue); //Direction will be ignored
|
||||
end;
|
||||
end;
|
||||
|
||||
if SHOW_PROJECTILES then
|
||||
begin
|
||||
gRenderAux.Projectile(fItems[I].fScreenStart.X,
|
||||
fItems[I].fScreenStart.Y,
|
||||
fItems[I].fScreenEnd.X,
|
||||
fItems[I].fScreenEnd.Y);
|
||||
|
||||
gRenderAux.Projectile(fItems[I].fAim.X,
|
||||
fItems[I].fAim.Y,
|
||||
fItems[I].fTarget.X,
|
||||
fItems[I].fTarget.Y);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMProjectiles.Save(SaveStream: TKMemoryStream);
|
||||
var
|
||||
I, liveCount: Integer;
|
||||
begin
|
||||
SaveStream.PlaceMarker('Projectiles');
|
||||
|
||||
//Strip dead projectiles
|
||||
liveCount := 0;
|
||||
for I := 0 to Length(fItems) - 1 do
|
||||
//if fItems[I].fSpeed <> 0 then // This causes desynchronization in replay
|
||||
Inc(liveCount);
|
||||
|
||||
SaveStream.Write(liveCount);
|
||||
|
||||
for I := 0 to Length(fItems) - 1 do
|
||||
//if fItems[I].fSpeed <> 0 then // This causes desynchronization in replay
|
||||
begin
|
||||
SaveStream.Write(fItems[I].fScreenStart);
|
||||
SaveStream.Write(fItems[I].fScreenEnd);
|
||||
SaveStream.Write(fItems[I].fAim);
|
||||
SaveStream.Write(fItems[I].fTarget);
|
||||
SaveStream.Write(fItems[I].fShotFrom);
|
||||
SaveStream.Write(fItems[I].fType, SizeOf(TKMProjectileType));
|
||||
SaveStream.Write(fItems[I].fOwner.UID); //Store ID
|
||||
SaveStream.Write(fItems[I].fSpeed);
|
||||
SaveStream.Write(fItems[I].fArc);
|
||||
SaveStream.Write(fItems[I].fPosition);
|
||||
SaveStream.Write(fItems[I].fLength);
|
||||
SaveStream.Write(fItems[I].fMaxLength);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMProjectiles.Load(LoadStream: TKMemoryStream);
|
||||
var
|
||||
I, newCount: Integer;
|
||||
begin
|
||||
LoadStream.CheckMarker('Projectiles');
|
||||
|
||||
LoadStream.Read(newCount);
|
||||
SetLength(fItems, newCount);
|
||||
|
||||
for I := 0 to newCount - 1 do
|
||||
begin
|
||||
LoadStream.Read(fItems[I].fScreenStart);
|
||||
LoadStream.Read(fItems[I].fScreenEnd);
|
||||
LoadStream.Read(fItems[I].fAim);
|
||||
LoadStream.Read(fItems[I].fTarget);
|
||||
LoadStream.Read(fItems[I].fShotFrom);
|
||||
LoadStream.Read(fItems[I].fType, SizeOf(TKMProjectileType));
|
||||
LoadStream.Read(fItems[I].fOwner, 4);
|
||||
LoadStream.Read(fItems[I].fSpeed);
|
||||
LoadStream.Read(fItems[I].fArc);
|
||||
LoadStream.Read(fItems[I].fPosition);
|
||||
LoadStream.Read(fItems[I].fLength);
|
||||
LoadStream.Read(fItems[I].fMaxLength);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMProjectiles.SyncLoad;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
for I := 0 to Length(fItems) - 1 do
|
||||
fItems[I].fOwner := gHands.GetUnitByUID(Integer(fItems[I].fOwner));
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
Vendored
+244
@@ -0,0 +1,244 @@
|
||||
unit KM_System;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
{$IFDEF MSWindows} Windows, {$ENDIF}
|
||||
{$IFDEF Unix} LCLIntf, LCLType, {$ENDIF}
|
||||
KM_ResSprites, KM_ResTypes,
|
||||
KM_Defaults;
|
||||
|
||||
|
||||
type
|
||||
// System related features are encapsulated in this class
|
||||
TKMSystem = class
|
||||
private
|
||||
{$IFNDEF FPC}
|
||||
{$IFDEF MSWindows}
|
||||
fFormMainHandle: HWND;
|
||||
fFlashing: Boolean;
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
function GetCursor: TKMCursorImageType;
|
||||
procedure SetCursor(Value: TKMCursorImageType);
|
||||
public
|
||||
constructor Create(aFormMainHandle: HWND);
|
||||
|
||||
property Cursor: TKMCursorImageType read GetCursor write SetCursor;
|
||||
|
||||
procedure MakeCursors(aSprites: TKMSpritePack);
|
||||
|
||||
procedure FlashingStart;
|
||||
procedure FlashingStop;
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
gSystem: TKMSystem;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
SysUtils, Math,
|
||||
Forms, Graphics;
|
||||
|
||||
const
|
||||
// Screen.Cursors[0] is used by System default cursor
|
||||
CURSOR_CNT_OFFSET = 1;
|
||||
|
||||
// New custom cursors count
|
||||
CUSTOM_CUR_CNT = 1;
|
||||
|
||||
CUSTOM_CURSORS: array [0..CUSTOM_CUR_CNT-1] of TKMCursorImageType = (kmcAnimatedDirSelector);
|
||||
|
||||
|
||||
{ TKMSystem }
|
||||
constructor TKMSystem.Create(aFormMainHandle: HWND);
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
{$IFNDEF FPC}
|
||||
{$IFDEF MSWindows}
|
||||
fFormMainHandle := aFormMainHandle;
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
function TKMSystem.GetCursor: TKMCursorImageType;
|
||||
begin
|
||||
if InRange(Screen.Cursor - CURSOR_CNT_OFFSET, Ord(Low(TKMCursorImageType)), Ord(High(TKMCursorImageType))) then
|
||||
Result := TKMCursorImageType(Screen.Cursor - CURSOR_CNT_OFFSET)
|
||||
else
|
||||
Result := kmcDefault;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMSystem.SetCursor(Value: TKMCursorImageType);
|
||||
begin
|
||||
if SKIP_LOADING_CURSOR then Exit;
|
||||
Screen.Cursor := Ord(Value) + CURSOR_CNT_OFFSET;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMSystem.MakeCursors(aSprites: TKMSpritePack);
|
||||
const
|
||||
SF = 17; //Full width/height of a scroll cursor
|
||||
SH = 8; //Half width/height of a scroll cursor
|
||||
// Measured manually
|
||||
CURSOR_OFFSET_X: array [TKMCursorImageType] of Integer = (0,0,20, 0, 0,-8, 9,0, 1,1,1,0,-1,-1,-1,0, SH,SF,SF,SF,SH, 0, 0,0, 0,0,0,27,0);
|
||||
CURSOR_OFFSET_Y: array [TKMCursorImageType] of Integer = (0,9,10,18,20,44,13,0,-1,0,1,1, 1, 0,-1,0, 0 ,0 ,SH,SF,SF,SF,SH,0,28,0,0,28,0);
|
||||
|
||||
CUSTOM_CUR_FILENAME: array[0..CUSTOM_CUR_CNT-1] of UnicodeString = ('cur1.ani');
|
||||
var
|
||||
C: TKMCursorImageType;
|
||||
I, sx, sy, x, y: Integer;
|
||||
bm, bm2: TBitmap;
|
||||
iconInfo: TIconInfo;
|
||||
Px: PRGBQuad;
|
||||
h : THandle;
|
||||
path: PChar;
|
||||
rxData: PRXData;
|
||||
begin
|
||||
if SKIP_RENDER then Exit;
|
||||
|
||||
rxData := @aSprites.RXData; // Store pointer to record instead of duplicating it
|
||||
|
||||
bm := TBitmap.Create; bm.HandleType := bmDIB; bm.PixelFormat := pf32bit;
|
||||
bm2 := TBitmap.Create; bm2.HandleType := bmDIB; bm2.PixelFormat := pf32bit;
|
||||
|
||||
for C := Low(TKMCursorImageType) to kmcPaintBucket do
|
||||
begin
|
||||
// Special case for invisible cursor
|
||||
if C = kmcInvisible then
|
||||
begin
|
||||
bm.Width := 1; bm.Height := 1;
|
||||
bm2.Width := 1; bm2.Height := 1;
|
||||
bm2.Canvas.Pixels[0,0] := clWhite; //Invisible mask, we don't care for Image color
|
||||
iconInfo.xHotspot := 0;
|
||||
iconInfo.yHotspot := 0;
|
||||
end
|
||||
else
|
||||
begin
|
||||
// Just skip missing cursor, do not crash the game
|
||||
if CURSOR_SPRITE_INDEX[C] >= Length(rxData.Size) then
|
||||
Continue;
|
||||
|
||||
sx := rxData.Size[CURSOR_SPRITE_INDEX[C]].X;
|
||||
sy := rxData.Size[CURSOR_SPRITE_INDEX[C]].Y;
|
||||
bm.Width := sx; bm.Height := sy;
|
||||
bm2.Width := sx; bm2.Height := sy;
|
||||
|
||||
for y := 0 to sy - 1 do
|
||||
begin
|
||||
Px := bm.ScanLine[y];
|
||||
for x := 0 to sx - 1 do
|
||||
begin
|
||||
if rxData.RGBA[CURSOR_SPRITE_INDEX[C],y*sx+x] and $FF000000 = 0 then
|
||||
Px.rgbReserved := $00
|
||||
else
|
||||
Px.rgbReserved := $FF;
|
||||
// Here we have BGR, not RGB
|
||||
Px.rgbBlue := (rxData.RGBA[CURSOR_SPRITE_INDEX[C],y*sx+x] and $FF0000) shr 16;
|
||||
Px.rgbGreen := (rxData.RGBA[CURSOR_SPRITE_INDEX[C],y*sx+x] and $FF00) shr 8;
|
||||
Px.rgbRed := rxData.RGBA[CURSOR_SPRITE_INDEX[C],y*sx+x] and $FF;
|
||||
Inc(Px);
|
||||
end;
|
||||
end;
|
||||
//Load hotspot offsets from RX file, adding the manual offsets (normally 0)
|
||||
iconInfo.xHotspot := Max(-rxData.Pivot[CURSOR_SPRITE_INDEX[C]].x + CURSOR_OFFSET_X[C], 0);
|
||||
iconInfo.yHotspot := Max(-rxData.Pivot[CURSOR_SPRITE_INDEX[C]].y + CURSOR_OFFSET_Y[C], 0);
|
||||
end;
|
||||
|
||||
//Release the Mask, otherwise there is black rect in Lazarus
|
||||
//it works only from within the loop, means mask is recreated when we access canvas or something like that
|
||||
bm2.ReleaseMaskHandle;
|
||||
|
||||
iconInfo.fIcon := False; //True=Icon, False=Cursor
|
||||
iconInfo.hbmColor := bm.Handle;
|
||||
|
||||
//I have a suspicion that maybe Windows could create icon delayed, at a time when bitmap data is
|
||||
//no longer valid (replaced by other bitmap or freed). Hence issues with transparency.
|
||||
{$IFDEF MSWindows}
|
||||
iconInfo.hbmMask := bm2.Handle;
|
||||
Screen.Cursors[Byte(C) + CURSOR_CNT_OFFSET] := CreateIconIndirect(iconInfo);
|
||||
{$ENDIF}
|
||||
{$IFDEF Unix}
|
||||
bm2.Mask(clWhite);
|
||||
IconInfo.hbmMask := bm2.MaskHandle;
|
||||
Screen.Cursors[Byte(C) + CURSOR_CNT_OFFSET] := CreateIconIndirect(@IconInfo);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
bm.Free;
|
||||
bm2.Free;
|
||||
|
||||
{$IFDEF WDC}
|
||||
for I := Low(CUSTOM_CURSORS) to High(CUSTOM_CURSORS) do
|
||||
begin
|
||||
path := PChar(ExeDir + 'data' + PathDelim + 'cursors' + PathDelim + CUSTOM_CUR_FILENAME[I]);
|
||||
h := LoadImage(0,
|
||||
path,
|
||||
IMAGE_CURSOR,
|
||||
35,
|
||||
36,
|
||||
LR_DEFAULTSIZE or
|
||||
LR_LOADFROMFILE);
|
||||
|
||||
if h <> 0 then
|
||||
Screen.Cursors[Byte(CUSTOM_CURSORS[I]) + CURSOR_CNT_OFFSET] := h
|
||||
else
|
||||
// Use default cursor, in case of missing cursor file
|
||||
Screen.Cursors[Byte(CUSTOM_CURSORS[I]) + CURSOR_CNT_OFFSET] := Screen.Cursors[Byte(kmcDefault) + CURSOR_CNT_OFFSET];
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMSystem.FlashingStart;
|
||||
{$IFNDEF FPC}{$IFDEF MSWindows}
|
||||
var
|
||||
flashInfo: TFlashWInfo;
|
||||
{$ENDIF}{$ENDIF}
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
|
||||
{$IFNDEF FPC}{$IFDEF MSWindows}
|
||||
if (GetForegroundWindow <> fFormMainHandle) then
|
||||
begin
|
||||
flashInfo.cbSize := 20;
|
||||
flashInfo.hwnd := Application.Handle;
|
||||
flashInfo.dwflags := FLASHW_ALL;
|
||||
flashInfo.ucount := 5; // Flash 5 times
|
||||
flashInfo.dwtimeout := 0; // Use default cursor blink rate
|
||||
fFlashing := True;
|
||||
FlashWindowEx(flashInfo);
|
||||
end
|
||||
{$ENDIF}{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMSystem.FlashingStop;
|
||||
{$IFNDEF FPC}{$IFDEF MSWindows}
|
||||
var
|
||||
flashInfo: TFlashWInfo;
|
||||
{$ENDIF}{$ENDIF}
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
|
||||
{$IFNDEF FPC}{$IFDEF MSWindows}
|
||||
if fFlashing then
|
||||
begin
|
||||
flashInfo.cbSize := 20;
|
||||
flashInfo.hwnd := Application.Handle;
|
||||
flashInfo.dwflags := FLASHW_STOP;
|
||||
flashInfo.ucount := 0;
|
||||
flashInfo.dwtimeout := 0;
|
||||
fFlashing := False;
|
||||
FlashWindowEx(flashInfo);
|
||||
end
|
||||
{$ENDIF}{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
Vendored
+702
@@ -0,0 +1,702 @@
|
||||
unit KM_AI;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
KM_CommonClasses, KM_CommonTypes, KM_Defaults,
|
||||
KM_Houses, KM_Units, KM_UnitWarrior, KM_Points,
|
||||
KM_AISetup, KM_AIMayor, KM_AIGoals, KM_AIGeneral,
|
||||
KM_CityManagement, KM_ArmyManagement, KM_GameTypes;
|
||||
|
||||
type
|
||||
//Things that player does automatically
|
||||
//Player AI exists both for AI and Human players, but for AI it does significantly more
|
||||
TKMHandAI = class
|
||||
private
|
||||
fOwner: TKMHandID;
|
||||
|
||||
fGeneral: TKMGeneral;
|
||||
fGoals: TKMGoals;
|
||||
fMayor: TKMayor;
|
||||
fSetup: TKMHandAISetup;
|
||||
|
||||
fCityManagement: TKMCityManagement;
|
||||
fArmyManagement: TKMArmyManagement;
|
||||
|
||||
fWonOrLost: TWonOrLost; //Has this player won/lost? If so, do not check goals
|
||||
|
||||
fCanBeAITypes: TKMAITypeSet;
|
||||
|
||||
procedure CheckGoals(aAllowResetGoals: Boolean = False);
|
||||
function GetHasWon: Boolean;
|
||||
function GetHasLost: Boolean;
|
||||
function GetIsNotWinnerNotLoser: Boolean;
|
||||
function GetGoals: TKMGoals;
|
||||
function GetSetup: TKMHandAISetup;
|
||||
public
|
||||
constructor Create(aHandIndex: TKMHandID);
|
||||
destructor Destroy; override;
|
||||
|
||||
property General: TKMGeneral read fGeneral;
|
||||
property Goals: TKMGoals read GetGoals;
|
||||
property Mayor: TKMayor read fMayor;
|
||||
property Setup: TKMHandAISetup read GetSetup;
|
||||
|
||||
property CityManagement: TKMCityManagement read fCityManagement;
|
||||
property ArmyManagement: TKMArmyManagement read fArmyManagement;
|
||||
|
||||
property CanBeAITypes: TKMAITypeSet read fCanBeAITypes write fCanBeAITypes;
|
||||
|
||||
procedure ResetWonOrLost;
|
||||
procedure Defeat(aShowDefeatMessage: Boolean = True); //Defeat the player, this is not reversible
|
||||
procedure Victory; //Set this player as victorious, this is not reversible
|
||||
procedure AddDefaultGoals(aBuildings: Boolean);
|
||||
property WonOrLost: TWonOrLost read fWonOrLost;
|
||||
property HasWon: Boolean read GetHasWon;
|
||||
property HasLost: Boolean read GetHasLost;
|
||||
procedure RecheckGoals;
|
||||
property IsNotWinnerNotLoser: Boolean read GetIsNotWinnerNotLoser;
|
||||
function GetWonOrLostString: UnicodeString; //Get string represantation of Hand WonOrLost
|
||||
procedure OwnerUpdate(aPlayer: TKMHandID);
|
||||
procedure HouseAttackNotification(aHouse: TKMHouse; aAttacker: TKMUnitWarrior);
|
||||
procedure UnitHPDecreaseNotification(aUnit: TKMUnit; aAttacker: TKMUnit; aNotifyScript: Boolean = True);
|
||||
procedure UnitAttackNotification(aUnit: TKMUnit; aAttacker: TKMUnit; aNotifyScript: Boolean = True);
|
||||
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure Load(LoadStream: TKMemoryStream);
|
||||
procedure SyncLoad();
|
||||
procedure UpdateState(aTick: Cardinal; aCheckGoals: Boolean);
|
||||
procedure AfterMissionInit(aCanBeAITypes: TKMAITypeSet);
|
||||
procedure PlaceFirstStorehouse(aLoc: TKMPoint); //RMG
|
||||
|
||||
function ObjToString: String;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
SysUtils, TypInfo, Math,
|
||||
KM_GameApp, KM_Game, KM_Hand, KM_HandsCollection, KM_HandStats, KM_UnitGroup,
|
||||
KM_ResSound, KM_ScriptingEvents, KM_Alerts,
|
||||
KM_AIFields, KM_Terrain, KM_ResMapElements, KM_DevPerfLog, KM_DevPerfLogTypes,
|
||||
KM_HandTypes,
|
||||
KM_MapTypes,
|
||||
KM_ResTypes;
|
||||
|
||||
|
||||
{ TKMHandAI }
|
||||
constructor TKMHandAI.Create(aHandIndex: TKMHandID);
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
fOwner := aHandIndex;
|
||||
fSetup := TKMHandAISetup.Create;
|
||||
fMayor := TKMayor.Create(fOwner, fSetup);
|
||||
fGeneral := TKMGeneral.Create(fOwner, fSetup);
|
||||
fGoals := TKMGoals.Create;
|
||||
fWonOrLost := wolNone;
|
||||
|
||||
fCityManagement := TKMCityManagement.Create(fOwner, fSetup);
|
||||
fArmyManagement := TKMArmyManagement.Create(fOwner, fSetup);
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMHandAI.Destroy;
|
||||
begin
|
||||
fGoals.Free;
|
||||
fGeneral.Free;
|
||||
fMayor.Free;
|
||||
fSetup.Free;
|
||||
|
||||
fCityManagement.Free;
|
||||
fArmyManagement.Free;
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMHandAI.ResetWonOrLost;
|
||||
begin
|
||||
fWonOrLost := wolNone;
|
||||
end;
|
||||
|
||||
|
||||
//Defeat Player (from scripting?), this is not reversible.
|
||||
//Defeated player remains in place, but does no actions
|
||||
procedure TKMHandAI.Defeat(aShowDefeatMessage: Boolean = True);
|
||||
begin
|
||||
if fWonOrLost <> wolNone then Exit;
|
||||
|
||||
fWonOrLost := wolLost;
|
||||
|
||||
//Let the game know
|
||||
gGame.PlayerDefeat(fOwner, aShowDefeatMessage);
|
||||
|
||||
//Script may have additional event processors
|
||||
gScriptEvents.ProcPlayerDefeated(fOwner);
|
||||
end;
|
||||
|
||||
|
||||
//Set player to victorious (from scripting), this is not reversible.
|
||||
//You probably need to make sure all other players are defeated or victorious too
|
||||
//otherwise it will look odd.
|
||||
procedure TKMHandAI.Victory;
|
||||
begin
|
||||
if fWonOrLost <> wolNone then Exit;
|
||||
|
||||
fWonOrLost := wolWon;
|
||||
|
||||
//Replays/spectators don't see victory screen
|
||||
if not gGame.Params.IsReplay
|
||||
and (gGame.Params.IsMultiPlayerOrSpec or (gMySpectator.HandID = fOwner)) then //Let everyone know in MP mode
|
||||
gGame.PlayerVictory(fOwner);
|
||||
|
||||
//Script may have additional event processors
|
||||
gScriptEvents.ProcPlayerVictory(fOwner);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMHandAI.AddDefaultGoals(aBuildings: Boolean);
|
||||
var
|
||||
I: Integer;
|
||||
enemies: array of TKMHandID;
|
||||
begin
|
||||
SetLength(enemies, 0);
|
||||
for I := 0 to gHands.Count - 1 do
|
||||
if gHands[I].Enabled and (gHands[fOwner].Alliances[I] = atEnemy) then
|
||||
begin
|
||||
SetLength(enemies, Length(enemies)+1);
|
||||
enemies[High(enemies)] := I;
|
||||
end;
|
||||
Goals.AddDefaultGoals(aBuildings, fOwner, enemies);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMHandAI.RecheckGoals;
|
||||
begin
|
||||
CheckGoals(True);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMHandAI.CheckGoals(aAllowResetGoals: Boolean = False);
|
||||
|
||||
function GoalConditionSatisfied(const aGoal: TKMGoal): Boolean;
|
||||
var
|
||||
stats: TKMHandStats;
|
||||
begin
|
||||
Assert((aGoal.GoalCondition = gcTime) or (aGoal.HandIndex <> HAND_NONE), 'Only gcTime can have nil Player');
|
||||
|
||||
if aGoal.Disabled then
|
||||
Exit(True);
|
||||
|
||||
if aGoal.HandIndex <> HAND_NONE then
|
||||
stats := gHands[aGoal.HandIndex].Stats
|
||||
else
|
||||
stats := nil;
|
||||
|
||||
case aGoal.GoalCondition of
|
||||
gcBuildTutorial: Result := True; //Deprecated
|
||||
//gcTime is disabled as we process messages in Event system now. Return True so players
|
||||
//do not have to wait for all messages to show before they are allowed to win (same in TPR)
|
||||
gcTime: Result := True; //Deprecated
|
||||
gcBuildings: Result := (stats.GetHouseQty(GOAL_BUILDINGS_HOUSES) > 0);
|
||||
gcTroops: Result := (stats.GetArmyCount > 0);
|
||||
gcMilitaryAssets: Result := (stats.GetArmyCount > 0) or
|
||||
(stats.GetHouseQty([htBarracks, htCoalMine, htWeaponWorkshop, htArmorWorkshop, htStables,
|
||||
htIronMine, htIronSmithy ,htWeaponSmithy, htArmorSmithy, htTownHall,
|
||||
htSiegeWorkshop]) > 0);
|
||||
gcSerfsAndSchools: Result := (stats.GetHouseQty([htSchool]) > 0) or (stats.GetUnitQty(utSerf) > 0);
|
||||
gcEconomyBuildings: Result := (stats.GetHouseQty([htStore, htSchool, htInn]) > 0);
|
||||
else raise Exception.Create('Unknown goal');
|
||||
end;
|
||||
if aGoal.GoalStatus = gsFalse then
|
||||
Result := not Result; //Reverse condition
|
||||
end;
|
||||
|
||||
var
|
||||
I: Integer;
|
||||
hasVictoryGoal: Boolean;
|
||||
victorySatisfied, survivalSatisfied: Boolean;
|
||||
begin
|
||||
//If player has elected to play on past victory or defeat
|
||||
//then do not check for any further goals
|
||||
if not aAllowResetGoals and (fWonOrLost <> wolNone) then Exit;
|
||||
|
||||
//Assume they will win/survive, then prove it with goals
|
||||
hasVictoryGoal := False;
|
||||
victorySatisfied := True;
|
||||
survivalSatisfied := True;
|
||||
|
||||
with gHands[fOwner] do
|
||||
for I := 0 to Goals.Count - 1 do
|
||||
case Goals[I].GoalType of
|
||||
gltVictory: begin
|
||||
//In a sandbox or script-ruled mission there may be no victory conditions in Goals
|
||||
//so we make sure player wins by Goals only if he has such goals
|
||||
hasVictoryGoal := True;
|
||||
victorySatisfied := victorySatisfied and
|
||||
(gHands[Goals[I].HandIndex].AI.HasLost //if player is Lost then no need to check other Goal conditions
|
||||
or GoalConditionSatisfied(Goals[I]));
|
||||
end;
|
||||
gltSurvive: survivalSatisfied := survivalSatisfied and GoalConditionSatisfied(Goals[I]);
|
||||
end;
|
||||
//Messages in goals have been replaced by SCRIPT files, so this code is disabled now,
|
||||
//but kept in case we need it for something later. (conversion process?)
|
||||
|
||||
//Display message if set and not already shown and not a blank text
|
||||
{if (Goals[I].MessageToShow <> 0)
|
||||
and not Goals[I].MessageHasShown
|
||||
and (fTextLibrary[Goals[I].MessageToShow] <> '') then
|
||||
begin
|
||||
if MyPlayer = fPlayers[fHandIndex] then
|
||||
fGameG.ShowMessage(mkText, fTextLibrary[Goals[I].MessageToShow], KMPOINT_ZERO);
|
||||
Goals.SetMessageHasShown(I);
|
||||
end;}
|
||||
|
||||
//You can't win and lose at the same time. In KaM defeats override victories, except
|
||||
//when there are no goals defined, in which case you win for some weird reason...
|
||||
//But given that having no goals is pretty pointless we'll make defeat override so you can't
|
||||
//win battle missions by waiting for your troops to simultainiously starve to death.
|
||||
|
||||
//Now we know if player has been defeated or won
|
||||
if not survivalSatisfied then
|
||||
Defeat
|
||||
else
|
||||
if hasVictoryGoal and victorySatisfied then
|
||||
Victory
|
||||
else
|
||||
if aAllowResetGoals then
|
||||
ResetWonOrLost;
|
||||
end;
|
||||
|
||||
|
||||
function TKMHandAI.GetHasWon: Boolean;
|
||||
begin
|
||||
if Self = nil then Exit(False);
|
||||
|
||||
Result := fWonOrLost = wolWon;
|
||||
end;
|
||||
|
||||
|
||||
function TKMHandAI.GetGoals: TKMGoals;
|
||||
begin
|
||||
if Self = nil then Exit(nil);
|
||||
|
||||
Result := fGoals;
|
||||
end;
|
||||
|
||||
|
||||
function TKMHandAI.GetHasLost: Boolean;
|
||||
begin
|
||||
if Self = nil then Exit(False);
|
||||
|
||||
Result := fWonOrLost = wolLost;
|
||||
end;
|
||||
|
||||
|
||||
function TKMHandAI.GetIsNotWinnerNotLoser: Boolean;
|
||||
begin
|
||||
if Self = nil then Exit(False);
|
||||
|
||||
Result := fWonOrLost = wolNone;
|
||||
end;
|
||||
|
||||
|
||||
function TKMHandAI.GetSetup: TKMHandAISetup;
|
||||
begin
|
||||
if Self = nil then Exit(nil);
|
||||
|
||||
Result := fSetup;
|
||||
end;
|
||||
|
||||
|
||||
function TKMHandAI.GetWonOrLostString: UnicodeString;
|
||||
begin
|
||||
Result := '';
|
||||
case fWonOrLost of
|
||||
wolNone: Result := 'Undefined';
|
||||
wolWon: Result := 'Won';
|
||||
wolLost: Result := 'Lost';
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMHandAI.OwnerUpdate(aPlayer: TKMHandID);
|
||||
begin
|
||||
fOwner := aPlayer;
|
||||
fMayor.OwnerUpdate(fOwner);
|
||||
fGeneral.OwnerUpdate(fOwner);
|
||||
|
||||
fCityManagement.OwnerUpdate(fOwner);
|
||||
fArmyManagement.OwnerUpdate(fOwner);
|
||||
end;
|
||||
|
||||
|
||||
// aHouse is our house that was attacked
|
||||
procedure TKMHandAI.HouseAttackNotification(aHouse: TKMHouse; aAttacker: TKMUnitWarrior);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
case gHands[fOwner].HandType of
|
||||
hndHuman:
|
||||
begin
|
||||
// Our allies might like to help us too
|
||||
for I := 0 to gHands.Count-1 do
|
||||
if gHands[I].Enabled and gHands[I].IsComputer
|
||||
and (gHands.CheckAlliance(I, fOwner) = atAlly) and gHands[I].AI.Setup.DefendAllies then
|
||||
gHands[I].AI.General.RetaliateAgainstThreat(aAttacker);
|
||||
|
||||
// No fight alerts in replays/spectating, and only show alerts for ourselves
|
||||
if not gGame.Params.IsReplayOrSpectate
|
||||
and (fOwner = gMySpectator.HandID)
|
||||
and (aAttacker <> nil) then //Don't show alerts for annonymous attacks (e.g. script)
|
||||
gGame.GamePlayInterface.Alerts.AddFight(KMPointF(aHouse.Position), fOwner, anTown,
|
||||
gGameApp.GlobalTickCount + ALERT_DURATION[atFight]);
|
||||
end;
|
||||
hndComputer:
|
||||
begin
|
||||
if not (WonOrLost <> wolNone) then
|
||||
begin
|
||||
if fSetup.NewAI then
|
||||
begin
|
||||
// Do nothing (too CPU demanding)
|
||||
end
|
||||
else
|
||||
begin
|
||||
fGeneral.RetaliateAgainstThreat(aAttacker);
|
||||
// Our allies might like to help us too
|
||||
for I := 0 to gHands.Count-1 do
|
||||
if gHands[I].Enabled and gHands[I].IsComputer
|
||||
and (gHands.CheckAlliance(I, fOwner) = atAlly) and gHands[I].AI.Setup.DefendAllies then
|
||||
gHands[I].AI.General.RetaliateAgainstThreat(aAttacker);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
gScriptEvents.ProcHouseDamaged(aHouse, aAttacker); //At the end since it could destroy the house
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMHandAI.UnitHPDecreaseNotification(aUnit: TKMUnit; aAttacker: TKMUnit; aNotifyScript: Boolean = True);
|
||||
begin
|
||||
{
|
||||
if not (WonOrLost <> wolNone) then
|
||||
begin
|
||||
if fSetup.NewAI AND (gHands[fOwner].HandType <> hndHuman) then // Make sure that it is not player
|
||||
begin
|
||||
// Do nothing (too CPU demanding)
|
||||
end;
|
||||
end;
|
||||
//}
|
||||
if aNotifyScript then
|
||||
gScriptEvents.ProcUnitWounded(aUnit, aAttacker); //At the end since it could kill the unit
|
||||
end;
|
||||
|
||||
|
||||
// aUnit is our unit that was attacked
|
||||
procedure TKMHandAI.UnitAttackNotification(aUnit: TKMUnit; aAttacker: TKMUnit; aNotifyScript: Boolean = True);
|
||||
const
|
||||
NOTIFY_KIND: array [Boolean] of TKMAttackNotification = (anCitizens, anTroops);
|
||||
var
|
||||
I: Integer;
|
||||
group: TKMUnitGroup;
|
||||
begin
|
||||
case gHands[fOwner].HandType of
|
||||
hndHuman:
|
||||
begin
|
||||
// If we are attacked, then our allies might like to help us too
|
||||
if aAttacker is TKMUnitWarrior then
|
||||
begin
|
||||
// Our allies might like to help us too
|
||||
for I := 0 to gHands.Count-1 do
|
||||
if gHands[I].Enabled and gHands[I].IsComputer
|
||||
and (gHands.CheckAlliance(I, fOwner) = atAlly) and gHands[I].AI.Setup.DefendAllies then
|
||||
gHands[I].AI.General.RetaliateAgainstThreat(aAttacker);
|
||||
end;
|
||||
|
||||
// No fight alerts in replays, and only show alerts for ourselves
|
||||
if not gGame.Params.IsReplayOrSpectate
|
||||
and (fOwner = gMySpectator.HandID) then
|
||||
gGame.GamePlayInterface.Alerts.AddFight(aUnit.PositionF, fOwner, NOTIFY_KIND[aUnit is TKMUnitWarrior],
|
||||
gGameApp.GlobalTickCount + ALERT_DURATION[atFight]);
|
||||
end;
|
||||
hndComputer:
|
||||
begin
|
||||
if not (WonOrLost <> wolNone) then
|
||||
begin
|
||||
if fSetup.NewAI then
|
||||
begin
|
||||
// Do nothing (too CPU demanding)
|
||||
end
|
||||
else
|
||||
begin
|
||||
//If we are attacked, then we should counter attack the attacker (except if he is a recruit in tower)
|
||||
if aAttacker is TKMUnitWarrior then
|
||||
begin
|
||||
fGeneral.RetaliateAgainstThreat(aAttacker); //Nearby soldiers should come to assist
|
||||
|
||||
//Our allies might like to help us too
|
||||
for I := 0 to gHands.Count-1 do
|
||||
if gHands[I].Enabled and gHands[I].IsComputer
|
||||
and (gHands.CheckAlliance(I, fOwner) = atAlly) and gHands[I].AI.Setup.DefendAllies then
|
||||
gHands[I].AI.General.RetaliateAgainstThreat(aAttacker);
|
||||
|
||||
//If we are a warrior we can also attack that unit ourselves
|
||||
if aUnit is TKMUnitWarrior then
|
||||
begin
|
||||
group := gHands[fOwner].UnitGroups.GetGroupByMember(TKMUnitWarrior(aUnit));
|
||||
//It's ok for the group to be nil, the warrior could still be walking out of the barracks
|
||||
if (group <> nil) and not group.IsDead then
|
||||
//If we are already in the process of attacking something, don't change our minds,
|
||||
//otherwise you can make a unit walk backwards and forwards forever between two groups of archers
|
||||
if not group.InFight then
|
||||
//Make sure the group could possibly reach the offenders
|
||||
if group.CanWalkTo(aAttacker.Position, group.FightMaxRange) then
|
||||
group.OrderAttackUnit(aAttacker, True);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
if aNotifyScript then
|
||||
gScriptEvents.ProcUnitAttacked(aUnit, aAttacker); //At the end since it could kill the unit
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMHandAI.Save(SaveStream: TKMemoryStream);
|
||||
begin
|
||||
SaveStream.PlaceMarker('HandAI');
|
||||
SaveStream.Write(fOwner);
|
||||
SaveStream.Write(fWonOrLost, SizeOf(fWonOrLost));
|
||||
SaveStream.Write(fCanBeAITypes, SizeOf(fCanBeAITypes));
|
||||
|
||||
fSetup.Save(SaveStream);
|
||||
fGoals.Save(SaveStream);
|
||||
|
||||
if aitClassic in fCanBeAITypes then
|
||||
begin
|
||||
fGeneral.Save(SaveStream);
|
||||
fMayor.Save(SaveStream);
|
||||
end;
|
||||
|
||||
if aitAdvanced in fCanBeAITypes then
|
||||
begin
|
||||
fCityManagement.Save(SaveStream);
|
||||
fArmyManagement.Save(SaveStream);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMHandAI.Load(LoadStream: TKMemoryStream);
|
||||
begin
|
||||
LoadStream.CheckMarker('HandAI');
|
||||
LoadStream.Read(fOwner);
|
||||
LoadStream.Read(fWonOrLost, SizeOf(fWonOrLost));
|
||||
LoadStream.Read(fCanBeAITypes, SizeOf(fCanBeAITypes));
|
||||
|
||||
fSetup.Load(LoadStream);
|
||||
fGoals.Load(LoadStream);
|
||||
|
||||
if aitClassic in fCanBeAITypes then
|
||||
begin
|
||||
fGeneral.Load(LoadStream);
|
||||
fMayor.Load(LoadStream);
|
||||
end;
|
||||
|
||||
if aitAdvanced in fCanBeAITypes then
|
||||
begin
|
||||
fCityManagement.Load(LoadStream);
|
||||
fArmyManagement.Load(LoadStream);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMHandAI.SyncLoad();
|
||||
begin
|
||||
if aitClassic in fCanBeAITypes then
|
||||
fGeneral.SyncLoad();
|
||||
|
||||
if aitAdvanced in fCanBeAITypes then
|
||||
begin
|
||||
fArmyManagement.SyncLoad();
|
||||
fCityManagement.SyncLoad();
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMHandAI.AfterMissionInit(aCanBeAITypes: TKMAITypeSet);
|
||||
begin
|
||||
fCanBeAITypes := aCanBeAITypes;
|
||||
|
||||
// Do AI initialization only if there could be any AI of a certain type
|
||||
// We should do it at the game start, in case player will be swapped to AI player
|
||||
// Also we have to do it only at the game start for Advanced AI, because it considers teams and divide mines according to the teams
|
||||
if aitClassic in fCanBeAITypes then
|
||||
fMayor.AfterMissionInit();
|
||||
|
||||
if aitAdvanced in fCanBeAITypes then
|
||||
begin
|
||||
gAIFields.Eye.OwnerUpdate(fOwner);
|
||||
fCityManagement.AfterMissionInit();
|
||||
fArmyManagement.AfterMissionInit();
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMHandAI.UpdateState(aTick: Cardinal; aCheckGoals: Boolean);
|
||||
begin
|
||||
{$IFDEF DBG_PERFLOG}
|
||||
gPerfLogs.SectionEnter(psAI);
|
||||
{$ENDIF}
|
||||
try
|
||||
if (WonOrLost <> wolNone) then
|
||||
Exit;
|
||||
|
||||
//Check goals for all players to maintain multiplayer consistency
|
||||
//AI victory/defeat is used in scripts (e.g. OnPlayerDefeated in battle tutorial)
|
||||
if aCheckGoals and (((aTick + Byte(fOwner)) mod MAX_HANDS) = 0) then
|
||||
CheckGoals; //This procedure manages victory and loss
|
||||
|
||||
case gHands[fOwner].HandType of
|
||||
hndHuman: begin
|
||||
//Humans dont need AI management
|
||||
end;
|
||||
hndComputer: begin
|
||||
if fSetup.NewAI then
|
||||
begin
|
||||
gAIFields.Eye.OwnerUpdate(fOwner);
|
||||
fArmyManagement.UpdateState(aTick);
|
||||
fCityManagement.UpdateState(aTick);
|
||||
end
|
||||
else
|
||||
begin
|
||||
fMayor.UpdateState(aTick);
|
||||
fGeneral.UpdateState(aTick);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
{$IFDEF DBG_PERFLOG}
|
||||
gPerfLogs.SectionLeave(psAI);
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMHandAI.ObjToString: String;
|
||||
begin
|
||||
Result := 'WOL = ' + GetEnumName(TypeInfo(TWonOrLost), Integer(fWonOrLost));
|
||||
end;
|
||||
|
||||
|
||||
// RMG
|
||||
procedure TKMHandAI.PlaceFirstStorehouse(aLoc: TKMPoint);
|
||||
|
||||
// Get closest resource to location
|
||||
function GetClosestResource(var aRes: TKMPoint; aList: TKMPointList): Boolean;
|
||||
const
|
||||
SQR_MAX_DISTANCE = 20*20;
|
||||
var
|
||||
K: Integer;
|
||||
distance, bestDistance: Single;
|
||||
begin
|
||||
aRes := KMPOINT_ZERO; // Set default point to zero so there is not integer overflow during evaluation if resource does not exist
|
||||
bestDistance := 1e10;
|
||||
for K := 0 to aList.Count - 1 do
|
||||
begin
|
||||
distance := KMDistanceSqr(aLoc, aList[K]);
|
||||
if (distance < bestDistance) then
|
||||
begin
|
||||
bestDistance := distance;
|
||||
aRes := aList[K];
|
||||
end;
|
||||
end;
|
||||
Result := bestDistance < SQR_MAX_DISTANCE;
|
||||
end;
|
||||
|
||||
// Place road and return True if it is possible
|
||||
function AddRoad(aPoint: TKMPoint): Boolean;
|
||||
begin
|
||||
Result := gHands[fOwner].CanAddFieldPlan(KMPoint(aPoint.X, aPoint.Y), ftRoad);
|
||||
if Result then
|
||||
begin
|
||||
gTerrain.SetRoad(aPoint, fOwner);
|
||||
//Terrain under roads is flattened (fields are not)
|
||||
gTerrain.FlattenTerrain(aPoint);
|
||||
if gMapElements[gTerrain.Land^[aPoint.Y,aPoint.X].Obj].WineOrCorn then
|
||||
gTerrain.RemoveObject(aPoint);
|
||||
end;
|
||||
end;
|
||||
|
||||
// Find place for store
|
||||
procedure FindPlaceForStore(bStone, bGold, bIron: Boolean; aInitP, Stone, Gold, Iron: TKMPoint);
|
||||
const
|
||||
RAD = 15;
|
||||
var
|
||||
X, Y: Integer;
|
||||
price, bestPrice: Single;
|
||||
loc, bestLoc: TKMPoint;
|
||||
begin
|
||||
bestPrice := 1e10;
|
||||
for X := Max(1,aInitP.X-RAD) to Min(gTerrain.MapX-1,aInitP.X+RAD) do
|
||||
for Y := Max(1,aInitP.Y-RAD) to Min(gTerrain.MapY-1,aInitP.Y+RAD) do
|
||||
if gHands[fOwner].CanAddFieldPlan(KMPoint(X,Y+1), ftRoad) AND gHands[fOwner].CanAddHousePlanAI(X,Y,htStore,False) then
|
||||
begin
|
||||
//gTerrain.ScriptTrySetTileObject(X, Y, 0); // Debug (visualization)
|
||||
loc := KMPoint(X,Y);
|
||||
price :=
|
||||
+ 6 * Byte(bStone) * KMDistanceSqr(loc, Stone)
|
||||
+ 50 * (Byte(gTerrain.TileIsCoal(X, Y) > 1) + Byte(gTerrain.TileIsCoal(X, Y-1) > 1) + Byte(gTerrain.TileIsCoal(X, Y-2) > 1))
|
||||
+ 2 * Byte(bGold) * KMDistanceSqr(loc, Gold)
|
||||
+ 1 * Byte(bIron) * KMDistanceSqr(loc, Iron)
|
||||
- 20 * ( Byte(gHands[fOwner].CanAddFieldPlan(KMPoint(X,Y+2), ftRoad)) + Byte(gHands[fOwner].CanAddFieldPlan(KMPoint(X+1,Y+1), ftRoad)) + Byte(gHands[fOwner].CanAddFieldPlan(KMPoint(X-1,Y+1), ftRoad)) );
|
||||
|
||||
if (price < bestPrice) then
|
||||
begin
|
||||
bestPrice := price;
|
||||
bestLoc := loc;
|
||||
end;
|
||||
end;
|
||||
// Place storehouse
|
||||
if (bestPrice < 1E10) then
|
||||
gHands[fOwner].AddFirstStorehouse(bestLoc);
|
||||
end;
|
||||
|
||||
const
|
||||
MAX_DIST_FROM_STONES = 10;
|
||||
var
|
||||
bGold, bIron, bStone: Boolean;
|
||||
gold, iron, stone, initPoint: TKMPoint;
|
||||
begin
|
||||
// Find the closest resource
|
||||
bGold := GetClosestResource(gold, gAIFields.Eye.GoldLocs);
|
||||
bIron := GetClosestResource(iron, gAIFields.Eye.IronLocs);
|
||||
bStone := GetClosestResource(stone, gAIFields.Eye.StoneMiningTiles);
|
||||
// Apply logic
|
||||
if bStone then
|
||||
begin
|
||||
if bGold then
|
||||
initPoint := KMPoint( Round((stone.X*4+gold.X*2+aLoc.X)/7), Round((stone.Y*4+gold.Y*2+aLoc.Y)/7) )
|
||||
else if bIron then
|
||||
initPoint := KMPoint( Round((stone.X*4+iron.X+aLoc.X)/6), Round((stone.Y*4+iron.Y+aLoc.Y)/6) )
|
||||
else
|
||||
initPoint := stone;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if bGold then
|
||||
initPoint := gold
|
||||
else if bIron then
|
||||
initPoint := iron
|
||||
else
|
||||
Exit;
|
||||
end;
|
||||
// Find place for store
|
||||
FindPlaceForStore(bStone, bGold, bIron, initPoint, stone, gold, iron);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
+351
@@ -0,0 +1,351 @@
|
||||
unit KM_AIArmyEvaluation;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
KM_Defaults, KM_CommonClasses,
|
||||
KM_Units, KM_UnitGroup;
|
||||
|
||||
type
|
||||
TKMGroupEval = record
|
||||
Count: Integer;
|
||||
HitPoints, Attack, AttackHorse, Defence, DefenceProjectiles: Single;
|
||||
end;
|
||||
TKMFoodState = record
|
||||
Full, Middle, Low: Integer;
|
||||
end;
|
||||
TKMArmyEval = record
|
||||
FoodState: TKMFoodState;
|
||||
Groups: array[GROUP_TYPE_MIN..GROUP_TYPE_MAX] of TKMGroupEval;
|
||||
end;
|
||||
TKMGameEval = array[0 .. MAX_HANDS - 1] of TKMArmyEval;
|
||||
|
||||
TKMGroupStrengthArray = array[GROUP_TYPE_MIN..GROUP_TYPE_MAX] of Single;
|
||||
|
||||
//This class evaluate self army relatively enemy armies
|
||||
TKMArmyEvaluation = class
|
||||
private
|
||||
fEvals: TKMGameEval; //Results of evaluation
|
||||
|
||||
function CompareStrength(A, E: TKMArmyEval): Single;
|
||||
function GetAllianceStrength(const aAlliance: TKMHandIDArray): TKMArmyEval;
|
||||
procedure EvaluatePower(aPlayer: TKMHandID; aConsiderHitChance: Boolean = False);
|
||||
public
|
||||
constructor Create();
|
||||
destructor Destroy; override;
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure Load(LoadStream: TKMemoryStream);
|
||||
|
||||
function UnitEvaluation(aUT: TKMUnitType; aConsiderHitChance: Boolean = False): TKMGroupEval;
|
||||
function GroupEvaluation(aGroup: TKMUnitGroup; aConsiderHitChance: Boolean): TKMGroupEval;
|
||||
function PlayerEvaluation(aPlayer: TKMHandID): TKMArmyEval;
|
||||
function AllianceEvaluation(aPlayer: TKMHandID; aAlliance: TKMAllianceType): TKMArmyEval;
|
||||
|
||||
function CompareAllianceStrength(const aAlly, aEnemy: TKMHandIDArray): Single;
|
||||
function CheckFoodProblems(const aAlly: TKMHandIDArray): Boolean;
|
||||
procedure AfterMissionInit();
|
||||
procedure UpdateState(aTick: Cardinal);
|
||||
end;
|
||||
|
||||
|
||||
const
|
||||
HIT_CHANCE_MODIFIER = 0.5;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Classes, Math,
|
||||
KM_Hand, KM_HandsCollection, KM_HandStats,
|
||||
KM_UnitsCollection,
|
||||
KM_Resource, KM_ResUnits, KM_ResTypes;
|
||||
|
||||
|
||||
{ TKMArmyEvaluation }
|
||||
constructor TKMArmyEvaluation.Create();
|
||||
begin
|
||||
inherited Create;
|
||||
FillChar(fEvals, SizeOf(fEvals), #0);
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMArmyEvaluation.Destroy;
|
||||
begin
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyEvaluation.Save(SaveStream: TKMemoryStream);
|
||||
begin
|
||||
SaveStream.PlaceMarker('ArmyEvaluation');
|
||||
SaveStream.Write(fEvals, SizeOf(fEvals));
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyEvaluation.Load(LoadStream: TKMemoryStream);
|
||||
begin
|
||||
LoadStream.CheckMarker('ArmyEvaluation');
|
||||
LoadStream.Read(fEvals, SizeOf(fEvals));
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyEvaluation.UnitEvaluation(aUT: TKMUnitType; aConsiderHitChance: Boolean = False): TKMGroupEval;
|
||||
var
|
||||
unitSpec: TKMUnitSpec;
|
||||
begin
|
||||
// Fill array with reference values
|
||||
unitSpec := gRes.Units[aUT];
|
||||
Result.Count := 1;
|
||||
Result.HitPoints := unitSpec.HitPoints;
|
||||
Result.Attack := unitSpec.Attack;
|
||||
Result.AttackHorse := unitSpec.AttackHorse;
|
||||
Result.Defence := unitSpec.Defence;
|
||||
Result.DefenceProjectiles := unitSpec.GetDefenceVsProjectiles(False);
|
||||
if aConsiderHitChance and (UNIT_TO_GROUP_TYPE[aUT] = gtRanged) then
|
||||
Result.Attack := Result.Attack * HIT_CHANCE_MODIFIER;
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyEvaluation.GroupEvaluation(aGroup: TKMUnitGroup; aConsiderHitChance: Boolean): TKMGroupEval;
|
||||
var
|
||||
K: Integer;
|
||||
GE: TKMGroupEval;
|
||||
begin
|
||||
FillChar(Result, SizeOf(Result), #0);
|
||||
Result.Count := aGroup.Count;
|
||||
for K := 0 to aGroup.Count-1 do
|
||||
begin
|
||||
GE := UnitEvaluation(TKMUnit(aGroup.Members[K]).UnitType, aConsiderHitChance);
|
||||
with Result do
|
||||
begin
|
||||
HitPoints := HitPoints + GE.HitPoints;
|
||||
Attack := Attack + GE.Attack;
|
||||
AttackHorse := AttackHorse + GE.AttackHorse;
|
||||
Defence := Defence + GE.Defence;
|
||||
DefenceProjectiles := DefenceProjectiles + GE.DefenceProjectiles;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyEvaluation.PlayerEvaluation(aPlayer: TKMHandID): TKMArmyEval;
|
||||
begin
|
||||
Move(fEvals[aPlayer], Result, SizeOf(fEvals[aPlayer]));
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyEvaluation.AllianceEvaluation(aPlayer: TKMHandID; aAlliance: TKMAllianceType): TKMArmyEval;
|
||||
var
|
||||
Cnt: Integer;
|
||||
PL: TKMHandID;
|
||||
Alliance: TKMHandIDArray;
|
||||
begin
|
||||
Cnt := 0;
|
||||
SetLength(Alliance, gHands.Count);
|
||||
for PL := 0 to gHands.Count - 1 do
|
||||
begin
|
||||
Alliance[Cnt] := PL;
|
||||
Inc(Cnt, Byte( gHands[PL].Enabled AND (gHands[aPlayer].Alliances[PL] = aAlliance) ));
|
||||
end;
|
||||
SetLength(Alliance,Cnt);
|
||||
Result := GetAllianceStrength(Alliance);
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyEvaluation.CompareStrength(A, E: TKMArmyEval): Single;
|
||||
// Sum power of all types of groups
|
||||
procedure SumPower(var aEval: TKMGroupEval; var Army: TKMArmyEval);
|
||||
var
|
||||
GT: TKMGroupType;
|
||||
begin
|
||||
FillChar(aEval, SizeOf(aEval), #0);
|
||||
for GT := GROUP_TYPE_MIN to GROUP_TYPE_MAX do
|
||||
begin
|
||||
aEval.Count := aEval.Count + Army.Groups[GT].Count ;
|
||||
aEval.HitPoints := aEval.HitPoints + Army.Groups[GT].HitPoints ;
|
||||
aEval.Attack := aEval.Attack + Army.Groups[GT].Attack ;
|
||||
aEval.AttackHorse := aEval.AttackHorse + Army.Groups[GT].AttackHorse ;
|
||||
aEval.Defence := aEval.Defence + Army.Groups[GT].Defence ;
|
||||
aEval.DefenceProjectiles := aEval.DefenceProjectiles + Army.Groups[GT].DefenceProjectiles;
|
||||
end;
|
||||
end;
|
||||
var
|
||||
AEval, EEval: TKMGroupEval;
|
||||
begin
|
||||
// Sum power of groups in alliance
|
||||
SumPower(AEval,A);
|
||||
SumPower(EEval,E);
|
||||
// Get weighted power with consideration of hostile groups
|
||||
AEval.AttackHorse := AEval.AttackHorse * E.Groups[gtMounted].Count / Max(1, EEval.Count);
|
||||
EEval.AttackHorse := EEval.AttackHorse * A.Groups[gtMounted].Count / Max(1, AEval.Count);
|
||||
AEval.DefenceProjectiles := AEval.DefenceProjectiles * E.Groups[gtRanged].Count / Max(1, EEval.Count);
|
||||
EEval.DefenceProjectiles := EEval.DefenceProjectiles * A.Groups[gtRanged].Count / Max(1, AEval.Count);
|
||||
// Get balance of power
|
||||
Result := (
|
||||
+ 1 - Min(2,(EEval.Attack + EEval.AttackHorse ) / Max(1,(AEval.Attack + AEval.AttackHorse )))
|
||||
+ 1 - Min(2,(EEval.HitPoints ) / Max(1,(AEval.HitPoints )))
|
||||
+ 1 - Min(2,(EEval.Defence + EEval.DefenceProjectiles) / Max(1,(AEval.Defence + AEval.DefenceProjectiles)))
|
||||
) / 3;
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyEvaluation.GetAllianceStrength(const aAlliance: TKMHandIDArray): TKMArmyEval;
|
||||
var
|
||||
PL: Integer;
|
||||
GT: TKMGroupType;
|
||||
begin
|
||||
FillChar(Result, SizeOf(Result), #0);
|
||||
for PL in aAlliance do
|
||||
begin
|
||||
for GT := GROUP_TYPE_MIN to GROUP_TYPE_MAX do
|
||||
with Result.Groups[GT] do
|
||||
begin
|
||||
Count := Count + fEvals[PL].Groups[GT].Count;
|
||||
HitPoints := HitPoints + fEvals[PL].Groups[GT].HitPoints;
|
||||
Attack := Attack + fEvals[PL].Groups[GT].Attack;
|
||||
AttackHorse := AttackHorse + fEvals[PL].Groups[GT].AttackHorse;
|
||||
Defence := Defence + fEvals[PL].Groups[GT].Defence;
|
||||
DefenceProjectiles := DefenceProjectiles + fEvals[PL].Groups[GT].DefenceProjectiles;
|
||||
end;
|
||||
with Result.FoodState do
|
||||
begin
|
||||
Inc(Full,fEvals[PL].FoodState.Full);
|
||||
Inc(Middle,fEvals[PL].FoodState.Middle);
|
||||
Inc(Low,fEvals[PL].FoodState.Low);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
// Approximate way how to compute strength of 2 alliances
|
||||
function TKMArmyEvaluation.CompareAllianceStrength(const aAlly, aEnemy: TKMHandIDArray): Single;
|
||||
var
|
||||
AllyEval, EnemyEval: TKMArmyEval;
|
||||
begin
|
||||
AllyEval := GetAllianceStrength(aAlly);
|
||||
EnemyEval := GetAllianceStrength(aEnemy);
|
||||
Result := CompareStrength(AllyEval, EnemyEval); // => number in <-1,1> ... positive = we have advantage and vice versa
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyEvaluation.CheckFoodProblems(const aAlly: TKMHandIDArray): Boolean;
|
||||
const
|
||||
FOOD_THRESHOLD = 0.75;
|
||||
var
|
||||
Full, Middle, Low, Food: Integer;
|
||||
PL: TKMHandID;
|
||||
begin
|
||||
Result := False;
|
||||
Full := 0;
|
||||
Middle := 0;
|
||||
Low := 0;
|
||||
for PL in aAlly do
|
||||
begin
|
||||
Food := 0;
|
||||
Inc(Food ,gHands[PL].Stats.GetWareBalance(wtBread));
|
||||
Inc(Food ,gHands[PL].Stats.GetWareBalance(wtWine));
|
||||
Inc(Food ,gHands[PL].Stats.GetWareBalance(wtSausage));
|
||||
Inc(Food ,gHands[PL].Stats.GetWareBalance(wtFish));
|
||||
Inc(Full ,fEvals[PL].FoodState.Full);
|
||||
Inc(Middle,fEvals[PL].FoodState.Middle);
|
||||
Inc(Low ,max(0, fEvals[PL].FoodState.Low - Food));
|
||||
end;
|
||||
if ((Full + Middle + Low) > 0) then
|
||||
Result := ((Full + Middle) / Max(1, (Full + Middle + Low))) < FOOD_THRESHOLD;
|
||||
end;
|
||||
|
||||
|
||||
// Actualize power of specific player
|
||||
//
|
||||
// Equation of combat:
|
||||
//
|
||||
// Close combat
|
||||
// Attack (+ AttackHorse) (+ DirModifier) -> DirModifier is not considered in ArmyEvaluation
|
||||
// Probability = ---------------------------------------
|
||||
// Defence
|
||||
//
|
||||
// Ranged units
|
||||
// HitProbability = 1 - Distance; Distance in <0,1> -> Hit probability is considered as a decreasing of attack by HIT_CHANCE_MODIFIER
|
||||
// Attack
|
||||
// Probability = --------------------
|
||||
// DefenceProjectiles
|
||||
//
|
||||
// Probability > random number => decrease hitpoint; 0 hitpoints = unit is dead
|
||||
procedure TKMArmyEvaluation.EvaluatePower(aPlayer: TKMHandID; aConsiderHitChance: Boolean = False);
|
||||
procedure EvaluateFoodLevel();
|
||||
const
|
||||
FULL_LIMIT = Round(UNIT_MAX_CONDITION * 0.75);
|
||||
LOW_LIMIT = Round(UNIT_MAX_CONDITION * 0.3);
|
||||
var
|
||||
K, Condition, LowCnt, FullCnt: Integer;
|
||||
begin
|
||||
LowCnt := 0;
|
||||
FullCnt := 0;
|
||||
for K := 0 to gHands[aPlayer].Units.Count - 1 do
|
||||
begin
|
||||
Condition := gHands[aPlayer].Units[K].Condition;
|
||||
Inc(LowCnt, Byte(Condition < LOW_LIMIT));
|
||||
Inc(FullCnt,Byte(Condition > FULL_LIMIT));
|
||||
end;
|
||||
fEvals[aPlayer].FoodState.Low := LowCnt;
|
||||
fEvals[aPlayer].FoodState.Middle := gHands[aPlayer].Units.Count - LowCnt - FullCnt;
|
||||
fEvals[aPlayer].FoodState.Full := FullCnt;
|
||||
end;
|
||||
var
|
||||
Stats: TKMHandStats;
|
||||
Qty: Integer;
|
||||
US: TKMUnitSpec;
|
||||
UT: TKMUnitType;
|
||||
GT: TKMGroupType;
|
||||
begin
|
||||
Stats := gHands[aPlayer].Stats;
|
||||
|
||||
// Clear array
|
||||
FillChar(fEvals[aPlayer], SizeOf(fEvals[aPlayer]), #0);
|
||||
|
||||
// Fill array with reference values
|
||||
for UT := WARRIOR_MIN to WARRIOR_MAX do
|
||||
begin
|
||||
Qty := Stats.GetUnitQty(UT);
|
||||
US := gRes.Units[UT];
|
||||
GT := UNIT_TO_GROUP_TYPE[UT];
|
||||
with fEvals[aPlayer].Groups[GT] do
|
||||
begin
|
||||
Count := Count + Qty;
|
||||
HitPoints := HitPoints + Qty * US.HitPoints;
|
||||
Attack := Attack + Qty * US.Attack;
|
||||
AttackHorse := AttackHorse + Qty * US.AttackHorse;
|
||||
Defence := Defence + Qty * US.Defence;
|
||||
DefenceProjectiles := DefenceProjectiles + Qty * US.GetDefenceVsProjectiles(False); // True = IsBolt -> calculation without bolts
|
||||
end;
|
||||
end;
|
||||
if aConsiderHitChance then
|
||||
with fEvals[aPlayer].Groups[gtRanged] do
|
||||
Attack := Attack * HIT_CHANCE_MODIFIER;
|
||||
|
||||
// Check if army is hungry
|
||||
EvaluateFoodLevel();
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyEvaluation.AfterMissionInit();
|
||||
var
|
||||
PL: TKMHandID;
|
||||
begin
|
||||
for PL := 0 to gHands.Count - 1 do
|
||||
if gHands[PL].Enabled then
|
||||
EvaluatePower(PL, True);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyEvaluation.UpdateState(aTick: Cardinal);
|
||||
const
|
||||
PERF_SUM = MAX_HANDS * 10;
|
||||
var
|
||||
PL: Integer;
|
||||
begin
|
||||
PL := aTick mod PERF_SUM;
|
||||
if (PL < gHands.Count) AND gHands[PL].Enabled then
|
||||
EvaluatePower(PL, True);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
+210
@@ -0,0 +1,210 @@
|
||||
unit KM_AIAttacks;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
KM_Defaults, KM_CommonClasses, KM_Points, KM_AITypes;
|
||||
|
||||
|
||||
const
|
||||
//KaM uses 0 for repeating attack in TSK (disused and replaced with later by Remake), 1 for once and 2 for repeating in TPR
|
||||
RemakeAttackType: array [0..2] of TKMAIAttackType = (aatRepeating, aatOnce, aatRepeating);
|
||||
KaMAttackType: array [TKMAIAttackType] of Byte = (1, 0);
|
||||
|
||||
type
|
||||
//Records must be packed so they are stored identically in MP saves (? padding bytes are unknown values)
|
||||
TKMAIAttack = packed record
|
||||
UID: Integer; //Attack UID, used to remove attack from script
|
||||
AttackType: TKMAIAttackType; //Once or repeating
|
||||
HasOccured: Boolean; //Has this attack happened already?
|
||||
Delay: Cardinal; //The attack will not occur before this time has passed
|
||||
TotalMen: Integer; //Number of idle (i.e. back line) warriors required in the AI army before the attack will launch
|
||||
GroupAmounts: TKMGroupTypeArray; //How many squads of each group type will be taken
|
||||
RandomGroups: Boolean; //Used instead of GroupAmounts, chooses groups randomly taking at most TotalMen warriors
|
||||
Target: TKMAIAttackTarget;
|
||||
Range: Integer; //Will only occur when target is within this tile range (not properly tested yet)
|
||||
CustomPosition: TKMPoint; //Used when Target = attCustomPosition
|
||||
end;
|
||||
|
||||
|
||||
TKMAIAttacks = class
|
||||
private
|
||||
fCount: Integer;
|
||||
fAttacks: array of TKMAIAttack;
|
||||
function GetAttack(aIndex: Integer): TKMAIAttack;
|
||||
procedure SetAttack(aIndex: Integer; const aValue: TKMAIAttack);
|
||||
public
|
||||
property Count: Integer read fCount;
|
||||
property Items[aIndex: Integer]: TKMAIAttack read GetAttack write SetAttack; default;
|
||||
|
||||
function AddAttack(aAttack: TKMAIAttack): Integer; overload;
|
||||
function AddAttack(aAttackType: TKMAIAttackType; aDelay: Cardinal; aTotalMen: Integer; const aGroupAmounts: TKMGroupTypeArray;
|
||||
aRandomGroups: Boolean; aTarget: TKMAIAttackTarget; aRange: Integer; aCustomPosition: TKMPoint): Integer; overload;
|
||||
function AddAttack(aAttackType: TKMAIAttackType; aDelay: Cardinal; aTotalMen: Integer;
|
||||
aMeleeGroupCount, aAntiHorseGroupCount, aRangedGroupCount, aMountedGroupCount: Word;
|
||||
aRandomGroups: Boolean; aTarget: TKMAIAttackTarget; aRange: Integer; aCustomPosition: TKMPoint): Integer; overload;
|
||||
function Remove(aAttackUID: Integer): Boolean;
|
||||
procedure Delete(aIndex: Integer);
|
||||
function CanOccur(aIndex: Integer; const aMenAvailable: TKMGroupTypeArray; const aGroupsAvailable: TKMGroupTypeArray; aTick: Cardinal): Boolean;
|
||||
procedure HasOccured(aIndex: Integer);
|
||||
procedure Clear;
|
||||
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure Load(LoadStream: TKMemoryStream);
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Math, KM_Game, KM_GameUIDTracker;
|
||||
|
||||
|
||||
{ TKMAIAttacks }
|
||||
function TKMAIAttacks.CanOccur(aIndex: Integer; const aMenAvailable: TKMGroupTypeArray; const aGroupsAvailable: TKMGroupTypeArray; aTick: Cardinal): Boolean;
|
||||
var
|
||||
GT: TKMGroupType;
|
||||
totalMenAvailable: Word;
|
||||
begin
|
||||
totalMenAvailable := 0;
|
||||
//Must have enough men available out of the types of groups that will attack
|
||||
for GT := GROUP_TYPE_MIN to GROUP_TYPE_MAX do
|
||||
if fAttacks[aIndex].RandomGroups or (fAttacks[aIndex].GroupAmounts[GT] > 0) then
|
||||
Inc(totalMenAvailable, aMenAvailable[GT]);
|
||||
|
||||
Result := ((fAttacks[aIndex].AttackType = aatRepeating) or not fAttacks[aIndex].HasOccured)
|
||||
and (aTick >= fAttacks[aIndex].Delay)
|
||||
and (totalMenAvailable >= fAttacks[aIndex].TotalMen)
|
||||
and (totalMenAvailable > 0);
|
||||
|
||||
//Must have enough groups of each type
|
||||
if not fAttacks[aIndex].RandomGroups then
|
||||
for GT := GROUP_TYPE_MIN to GROUP_TYPE_MAX do
|
||||
Result := Result and (aGroupsAvailable[GT] >= fAttacks[aIndex].GroupAmounts[GT]);
|
||||
|
||||
//todo -cComplicated: Add support for the AI attack feature Range
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAIAttacks.HasOccured(aIndex: Integer);
|
||||
begin
|
||||
fAttacks[aIndex].HasOccured := True;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAIAttacks.Clear;
|
||||
begin
|
||||
SetLength(fAttacks, 0);
|
||||
fCount := 0;
|
||||
end;
|
||||
|
||||
|
||||
function TKMAIAttacks.AddAttack(aAttack: TKMAIAttack): Integer;
|
||||
begin
|
||||
if fCount >= Length(fAttacks) then
|
||||
SetLength(fAttacks, fCount + 16);
|
||||
|
||||
aAttack.UID := gUIDTracker.GetNewUID;
|
||||
fAttacks[fCount] := aAttack;
|
||||
Inc(fCount);
|
||||
Result := aAttack.UID;
|
||||
end;
|
||||
|
||||
|
||||
function TKMAIAttacks.AddAttack(aAttackType: TKMAIAttackType; aDelay: Cardinal; aTotalMen: Integer; const aGroupAmounts: TKMGroupTypeArray;
|
||||
aRandomGroups: Boolean; aTarget: TKMAIAttackTarget; aRange: Integer; aCustomPosition: TKMPoint): Integer;
|
||||
var
|
||||
attack: TKMAIAttack;
|
||||
begin
|
||||
attack.AttackType := aAttackType;
|
||||
attack.HasOccured := False;
|
||||
attack.Delay := aDelay;
|
||||
attack.TotalMen := aTotalMen;
|
||||
attack.GroupAmounts := aGroupAmounts;
|
||||
attack.RandomGroups := aRandomGroups;
|
||||
attack.Target := aTarget;
|
||||
attack.Range := aRange;
|
||||
attack.CustomPosition := aCustomPosition;
|
||||
Result := AddAttack(attack);
|
||||
end;
|
||||
|
||||
|
||||
function TKMAIAttacks.AddAttack(aAttackType: TKMAIAttackType; aDelay: Cardinal; aTotalMen: Integer;
|
||||
aMeleeGroupCount, aAntiHorseGroupCount, aRangedGroupCount, aMountedGroupCount: Word;
|
||||
aRandomGroups: Boolean; aTarget: TKMAIAttackTarget; aRange: Integer; aCustomPosition: TKMPoint): Integer;
|
||||
var
|
||||
groupAmounts: TKMGroupTypeArray;
|
||||
begin
|
||||
groupAmounts[gtMelee] := aMeleeGroupCount;
|
||||
groupAmounts[gtAntiHorse] := aAntiHorseGroupCount;
|
||||
groupAmounts[gtRanged] := aRangedGroupCount;
|
||||
groupAmounts[gtMounted] := aMountedGroupCount;
|
||||
Result := AddAttack(aAttackType, aDelay, aTotalMen, groupAmounts, aRandomGroups, aTarget, aRange, aCustomPosition);
|
||||
end;
|
||||
|
||||
|
||||
//Remove AIAttack by its ID
|
||||
//Result - True, if delete was succesfull, False, if no AIAttack was found
|
||||
function TKMAIAttacks.Remove(aAttackUID: Integer): Boolean;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
for I := 0 to fCount - 1 do
|
||||
if fAttacks[I].UID = aAttackUID then
|
||||
begin
|
||||
Delete(I);
|
||||
Result := True;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAIAttacks.Delete(aIndex: Integer);
|
||||
begin
|
||||
Assert(InRange(aIndex, 0, Count - 1));
|
||||
|
||||
if (aIndex <> Count - 1) then
|
||||
Move(fAttacks[aIndex + 1], fAttacks[aIndex], (Count - 1 - aIndex) * SizeOf(fAttacks[0]));
|
||||
|
||||
Dec(fCount);
|
||||
end;
|
||||
|
||||
|
||||
function TKMAIAttacks.GetAttack(aIndex: Integer): TKMAIAttack;
|
||||
begin
|
||||
Assert(InRange(aIndex, 0, fCount - 1));
|
||||
Result := fAttacks[aIndex];
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAIAttacks.SetAttack(aIndex: Integer; const aValue: TKMAIAttack);
|
||||
begin
|
||||
Assert(InRange(aIndex, 0, fCount - 1));
|
||||
fAttacks[aIndex] := aValue;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAIAttacks.Save(SaveStream: TKMemoryStream);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
SaveStream.PlaceMarker('AIAttacks');
|
||||
SaveStream.Write(fCount);
|
||||
for I := 0 to fCount - 1 do
|
||||
SaveStream.Write(fAttacks[I], SizeOf(fAttacks[I]));
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAIAttacks.Load(LoadStream: TKMemoryStream);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
LoadStream.CheckMarker('AIAttacks');
|
||||
LoadStream.Read(fCount);
|
||||
SetLength(fAttacks, fCount);
|
||||
for I := 0 to fCount - 1 do
|
||||
LoadStream.Read(fAttacks[I], SizeOf(fAttacks[I]));
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
+606
@@ -0,0 +1,606 @@
|
||||
unit KM_AICityPlanner;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
KM_TerrainFinder,
|
||||
|
||||
KM_CommonClasses, KM_Defaults, KM_Points,
|
||||
KM_ResTypes;
|
||||
|
||||
|
||||
type
|
||||
TFindNearest = (fnHouse, fnStone, fnTrees, fnSoil, fnWater, fnCoal, fnIron, fnGold);
|
||||
|
||||
// Terrain finder optimized for CityPlanner demands of finding resources and houses
|
||||
TKMTerrainFinderCity = class(TKMTerrainFinderCommon)
|
||||
protected
|
||||
fOwner: TKMHandID;
|
||||
function CanWalkHere(const X,Y: Word): Boolean; override;
|
||||
function CanUse(const X,Y: Word): Boolean; override;
|
||||
public
|
||||
FindType: TFindNearest;
|
||||
HouseType: TKMHouseType;
|
||||
constructor Create(aOwner: TKMHandID);
|
||||
procedure OwnerUpdate(aPlayer: TKMHandID);
|
||||
procedure Save(SaveStream: TKMemoryStream); override;
|
||||
procedure Load(LoadStream: TKMemoryStream); override;
|
||||
end;
|
||||
|
||||
TKMCityPlanner = class
|
||||
private
|
||||
fOwner: TKMHandID;
|
||||
fListGold: TKMPointList; // List of possible goldmine locations
|
||||
fFinder: TKMTerrainFinderCity;
|
||||
|
||||
function GetSeeds(aHouseType: array of TKMHouseType): TKMPointArray;
|
||||
|
||||
function NextToOre(aHouse: TKMHouseType; aOreType: TKMWareType; out aLoc: TKMPoint; aNearAnyHouse: Boolean = False): Boolean;
|
||||
function NextToHouse(aHouse: TKMHouseType; aSeed, aAvoid: array of TKMHouseType; out aLoc: TKMPoint): Boolean;
|
||||
function NextToStone(aHouse: TKMHouseType; out aLoc: TKMPoint): Boolean;
|
||||
function NextToTrees(aHouse: TKMHouseType; aSeed: array of TKMHouseType; out aLoc: TKMPoint): Boolean;
|
||||
function NextToGrass(aHouse: TKMHouseType; aSeed: array of TKMHouseType; out aLoc: TKMPoint): Boolean;
|
||||
public
|
||||
constructor Create(aPlayer: TKMHandID);
|
||||
destructor Destroy; override;
|
||||
|
||||
procedure AfterMissionInit;
|
||||
|
||||
function FindNearest(const aStart: TKMPoint; aRadius: Byte; aType: TFindNearest; out aResultLoc: TKMPoint): Boolean; overload;
|
||||
procedure FindNearest(const aStart: TKMPointArray; aRadius: Byte; aType: TFindNearest; aPass: TKMTerrainPassabilitySet; aMaxCount: Word; aLocs: TKMPointTagList); overload;
|
||||
procedure FindNearest(const aStart: TKMPointArray; aRadius: Byte; aHouse: TKMHouseType; aMaxCount: Word; aLocs: TKMPointTagList); overload;
|
||||
function FindPlaceForHouse(aHouse: TKMHouseType; out aLoc: TKMPoint): Boolean;
|
||||
procedure OwnerUpdate(aPlayer: TKMHandID);
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure Load(LoadStream: TKMemoryStream);
|
||||
end;
|
||||
|
||||
|
||||
const
|
||||
AI_FIELD_HEIGHT = 3;
|
||||
AI_FIELD_WIDTH = 4;
|
||||
AI_FIELD_MAX_AREA = (AI_FIELD_WIDTH * 2 + 1) * AI_FIELD_HEIGHT;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Math,
|
||||
KM_HandsCollection, KM_Hand, KM_HandTypes,
|
||||
KM_AIFields, KM_AIInfluences,
|
||||
KM_Terrain,
|
||||
KM_Resource, KM_ResUnits, KM_NavMesh,
|
||||
KM_Houses, KM_CommonUtils, KM_CommonTypes;
|
||||
|
||||
|
||||
{ TKMCityPlanner }
|
||||
constructor TKMCityPlanner.Create(aPlayer: TKMHandID);
|
||||
begin
|
||||
inherited Create;
|
||||
fOwner := aPlayer;
|
||||
fFinder := TKMTerrainFinderCity.Create(fOwner);
|
||||
|
||||
fListGold := TKMPointList.Create;
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMCityPlanner.Destroy;
|
||||
begin
|
||||
fListGold.Free;
|
||||
fFinder.Free;
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
function TKMCityPlanner.FindPlaceForHouse(aHouse: TKMHouseType; out aLoc: TKMPoint): Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
|
||||
case aHouse of
|
||||
htStore: Result := NextToHouse(aHouse, [htAny], [htStore], aLoc);
|
||||
htArmorSmithy: Result := NextToHouse(aHouse, [htIronSmithy, htCoalMine, htBarracks], [], aLoc);
|
||||
htArmorWorkshop: Result := NextToHouse(aHouse, [htTannery, htBarracks], [], aLoc);
|
||||
htBakery: Result := NextToHouse(aHouse, [htMill], [], aLoc);
|
||||
htBarracks: Result := NextToHouse(aHouse, [htAny], [], aLoc);
|
||||
htWatchTower: Result := NextToHouse(aHouse, [htBarracks], [], aLoc);
|
||||
htButchers: Result := NextToHouse(aHouse, [htSwine], [], aLoc);
|
||||
htInn: Result := NextToHouse(aHouse, [htAny], [htInn], aLoc);
|
||||
htIronSmithy: Result := NextToHouse(aHouse, [htIronMine, htCoalMine], [], aLoc);
|
||||
htMetallurgists: Result := NextToHouse(aHouse, [htGoldMine], [], aLoc);
|
||||
htMill: Result := NextToHouse(aHouse, [htFarm], [], aLoc);
|
||||
htSawmill: Result := NextToHouse(aHouse, [htWoodcutters], [], aLoc);
|
||||
htSchool: Result := NextToHouse(aHouse, [htStore, htBarracks], [], aLoc);
|
||||
htStables: Result := NextToHouse(aHouse, [htFarm], [], aLoc);
|
||||
htSwine: Result := NextToHouse(aHouse, [htFarm], [], aLoc);
|
||||
htTannery: Result := NextToHouse(aHouse, [htSwine], [], aLoc);
|
||||
htWeaponSmithy: Result := NextToHouse(aHouse, [htIronSmithy, htCoalMine, htBarracks], [], aLoc);
|
||||
htWeaponWorkshop: Result := NextToHouse(aHouse, [htSawmill, htBarracks], [], aLoc);
|
||||
|
||||
htCoalMine: Result := NextToOre(aHouse, wtCoal, aLoc);
|
||||
htGoldMine: Result := NextToOre(aHouse, wtGoldOre, aLoc);
|
||||
htIronMine: Result := NextToOre(aHouse, wtIronOre, aLoc);
|
||||
|
||||
htQuarry: Result := NextToStone(aHouse, aLoc);
|
||||
htWoodcutters: Result := NextToTrees(aHouse, [htStore, htWoodcutters, htSawmill], aLoc);
|
||||
htFarm: Result := NextToGrass(aHouse, [htAny], aLoc);
|
||||
htVineyard: Result := NextToGrass(aHouse, [htAny], aLoc);
|
||||
htFishermans: {Result := NextToWater(aHouse, aLoc)};
|
||||
|
||||
//htMarketplace:;
|
||||
//htSiegeWorkshop:;
|
||||
//htTownHall:;
|
||||
//htWatchTower:;
|
||||
end;
|
||||
|
||||
//If we failed to find something, try to place the house anywhere (better than ignoring it)
|
||||
if not Result and not (aHouse in [htCoalMine, htGoldMine, htIronMine, htQuarry, htFarm, htVineyard, htFishermans]) then
|
||||
Result := NextToHouse(aHouse, [htAny], [], aLoc);
|
||||
end;
|
||||
|
||||
|
||||
//Receive list of desired house types
|
||||
//Output list of locations below these houses
|
||||
function TKMCityPlanner.GetSeeds(aHouseType: array of TKMHouseType): TKMPointArray;
|
||||
var
|
||||
I, K: Integer;
|
||||
H: TKMHouseType;
|
||||
Count, HQty: Integer;
|
||||
House: TKMHouse;
|
||||
begin
|
||||
Count := 0;
|
||||
SetLength(Result, Count);
|
||||
|
||||
for I := Low(aHouseType) to High(aHouseType) do
|
||||
begin
|
||||
H := aHouseType[I];
|
||||
HQty := gHands[fOwner].Stats.GetHouseQty(H);
|
||||
//htAny picks three random houses for greater variety
|
||||
for K := 0 to 1 + Byte(H = htAny) * 2 do
|
||||
begin
|
||||
House := gHands[fOwner].Houses.FindHouse(H, 0, 0, KaMRandom(HQty{$IFDEF DBG_RNG_SPY}, 'TKMCityPlanner.GetSeeds'{$ENDIF}) + 1);
|
||||
if House <> nil then
|
||||
begin
|
||||
SetLength(Result, Count + 1);
|
||||
//Position is as good as Entrance for city planning
|
||||
Result[Count] := KMPointBelow(House.Position);
|
||||
Inc(Count);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCityPlanner.AfterMissionInit;
|
||||
var
|
||||
I,K: Integer;
|
||||
begin
|
||||
//Mark all spots where we could possibly place a goldmine
|
||||
//some smarter logic can clip left/right edges later on?
|
||||
for I := 1 to gTerrain.MapY - 2 do
|
||||
for K := 1 to gTerrain.MapX - 2 do
|
||||
if gTerrain.TileGoodForGoldmine(K,I) then
|
||||
fListGold.Add(KMPoint(K,I));
|
||||
end;
|
||||
|
||||
|
||||
function TKMCityPlanner.NextToGrass(aHouse: TKMHouseType; aSeed: array of TKMHouseType; out aLoc: TKMPoint): Boolean;
|
||||
function CanPlaceHouse(aHouse: TKMHouseType; aX, aY: Word): Boolean;
|
||||
var
|
||||
I, K: Integer;
|
||||
FieldCount: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
if gHands[fOwner].CanAddHousePlanAI(aX, aY, aHouse, True) then
|
||||
begin
|
||||
FieldCount := 0;
|
||||
for I := Min(aY - 2, gTerrain.MapY - 1) to Max(aY + 2 + AI_FIELD_HEIGHT - 1, 1) do
|
||||
for K := Max(aX - AI_FIELD_WIDTH, 1) to Min(aX + AI_FIELD_WIDTH, gTerrain.MapX - 1) do
|
||||
if gHands[fOwner].CanAddFieldPlan(KMPoint(K,I), ftCorn)
|
||||
//Skip fields within actual house areas
|
||||
and ((aHouse <> htFarm) or not InRange(I, aY-2, aY) or not InRange(K, aX-1, aX+2))
|
||||
and ((aHouse <> htVineyard) or not InRange(I, aY-1, aY) or not InRange(K, aX-2, aX)) then
|
||||
begin
|
||||
Inc(FieldCount);
|
||||
//Request slightly more than we need to have a good choice
|
||||
if FieldCount >= Min(AI_FIELD_MAX_AREA, IfThen(aHouse = htFarm, 16, 10)) then
|
||||
begin
|
||||
Result := True;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
var
|
||||
I, K, J: Integer;
|
||||
Bid, BestBid: Single;
|
||||
SeedLocs: TKMPointArray;
|
||||
S: TKMPoint;
|
||||
begin
|
||||
Result := False;
|
||||
Assert(aHouse in [htFarm, htVineyard]);
|
||||
|
||||
SeedLocs := GetSeeds(aSeed);
|
||||
|
||||
BestBid := MaxSingle;
|
||||
for J := Low(SeedLocs) to High(SeedLocs) do
|
||||
begin
|
||||
S := SeedLocs[J];
|
||||
for I := Max(S.Y - 7, 1) to Min(S.Y + 6, gTerrain.MapY - 1) do
|
||||
for K := Max(S.X - 7, 1) to Min(S.X + 7, gTerrain.MapX - 1) do
|
||||
if CanPlaceHouse(aHouse, K, I) then
|
||||
begin
|
||||
Bid := KMLength(KMPoint(K,I), S)
|
||||
- gAIFields.Influences.Ownership[fOwner, I, K] / 5
|
||||
+ KaMRandom({$IFDEF DBG_RNG_SPY}'TKMCityPlanner.NextToGrass'{$ENDIF}) * 4;
|
||||
if Bid < BestBid then
|
||||
begin
|
||||
aLoc := KMPoint(K,I);
|
||||
BestBid := Bid;
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMCityPlanner.NextToHouse(aHouse: TKMHouseType; aSeed, aAvoid: array of TKMHouseType; out aLoc: TKMPoint): Boolean;
|
||||
var
|
||||
I: Integer;
|
||||
Bid, BestBid: Single;
|
||||
SeedLocs: TKMPointArray;
|
||||
Locs: TKMPointTagList;
|
||||
begin
|
||||
Result := False;
|
||||
|
||||
SeedLocs := GetSeeds(aSeed);
|
||||
|
||||
Locs := TKMPointTagList.Create;
|
||||
try
|
||||
FindNearest(SeedLocs, 32, aHouse, 12, Locs);
|
||||
|
||||
BestBid := MaxSingle;
|
||||
for I := 0 to Locs.Count - 1 do
|
||||
begin
|
||||
Bid := Locs.Tag[I]
|
||||
- gAIFields.Influences.Ownership[fOwner,Locs[I].Y,Locs[I].X] / 5;
|
||||
if (Bid < BestBid) then
|
||||
begin
|
||||
aLoc := Locs[I];
|
||||
BestBid := Bid;
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
Locs.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
//Called when AI needs to find a good spot for a new Quary
|
||||
function TKMCityPlanner.NextToStone(aHouse: TKMHouseType; out aLoc: TKMPoint): Boolean;
|
||||
const
|
||||
SEARCH_RAD = 8;
|
||||
var
|
||||
I, K: Integer;
|
||||
Bid, BestBid: Single;
|
||||
StoneLoc: TKMPoint;
|
||||
Locs: TKMPointTagList;
|
||||
SeedLocs: TKMPointArray;
|
||||
J, M: Integer;
|
||||
tmp: TKMPointDir;
|
||||
begin
|
||||
Result := False;
|
||||
|
||||
SeedLocs := GetSeeds([htAny]);
|
||||
|
||||
Locs := TKMPointTagList.Create;
|
||||
try
|
||||
//Find all tiles from which stone can be mined, by walking to them
|
||||
FindNearest(SeedLocs, 32, fnStone, [tpWalk], 12, Locs);
|
||||
if Locs.Count = 0 then Exit;
|
||||
|
||||
//Check few random tiles if we can build Quary nearby
|
||||
BestBid := MaxSingle;
|
||||
for J := 0 to 2 do
|
||||
begin
|
||||
M := KaMRandom(Locs.Count{$IFDEF DBG_RNG_SPY}, 'TKMCityPlanner.NextToStone'{$ENDIF});
|
||||
StoneLoc := Locs[M];
|
||||
for I := Max(StoneLoc.Y - SEARCH_RAD, 1) to Min(StoneLoc.Y + SEARCH_RAD, gTerrain.MapY - 1) do
|
||||
for K := Max(StoneLoc.X - SEARCH_RAD, 1) to Min(StoneLoc.X + SEARCH_RAD, gTerrain.MapX - 1) do
|
||||
if gHands[fOwner].CanAddHousePlanAI(K, I, aHouse, True) then
|
||||
begin
|
||||
Bid := Locs.Tag[M]
|
||||
- gAIFields.Influences.Ownership[fOwner,I,K] / 10
|
||||
+ KaMRandom({$IFDEF DBG_RNG_SPY}'TKMCityPlanner.NextToStone_2'{$ENDIF}) * 3
|
||||
+ KMLengthDiag(K, I, StoneLoc); //Distance to stone is important
|
||||
if (Bid < BestBid) then
|
||||
begin
|
||||
aLoc := KMPoint(K,I);
|
||||
BestBid := Bid;
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
Locs.Free;
|
||||
end;
|
||||
|
||||
//Make sure stonemason actually can reach some stone (avoid build-destroy loop)
|
||||
if Result then
|
||||
if not gTerrain.FindStone(aLoc, gRes.Units[utStonemason].MiningRange, KMPOINT_ZERO, True, tmp) then
|
||||
Result := False;
|
||||
end;
|
||||
|
||||
|
||||
function TKMCityPlanner.FindNearest(const aStart: TKMPoint; aRadius: Byte; aType: TFindNearest; out aResultLoc: TKMPoint): Boolean;
|
||||
begin
|
||||
fFinder.FindType := aType;
|
||||
fFinder.HouseType := htNone;
|
||||
Result := fFinder.FindNearest(aStart, aRadius, [tpWalkRoad, tpMakeRoads], aResultLoc);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCityPlanner.FindNearest(const aStart: TKMPointArray; aRadius: Byte; aType: TFindNearest; aPass: TKMTerrainPassabilitySet; aMaxCount: Word; aLocs: TKMPointTagList);
|
||||
begin
|
||||
fFinder.FindType := aType;
|
||||
fFinder.HouseType := htNone;
|
||||
fFinder.FindNearest(aStart, aRadius, aPass, aMaxCount, aLocs);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCityPlanner.FindNearest(const aStart: TKMPointArray; aRadius: Byte; aHouse: TKMHouseType; aMaxCount: Word; aLocs: TKMPointTagList);
|
||||
begin
|
||||
fFinder.FindType := fnHouse;
|
||||
fFinder.HouseType := aHouse;
|
||||
fFinder.FindNearest(aStart, aRadius, [tpWalkRoad, tpMakeRoads], aMaxCount, aLocs);
|
||||
end;
|
||||
|
||||
|
||||
function TKMCityPlanner.NextToOre(aHouse: TKMHouseType; aOreType: TKMWareType; out aLoc: TKMPoint; aNearAnyHouse: Boolean = False): Boolean;
|
||||
var
|
||||
P: TKMPoint;
|
||||
SeedLocs: TKMPointArray;
|
||||
begin
|
||||
Result := False;
|
||||
|
||||
|
||||
//Look for nearest Ore
|
||||
case aOreType of
|
||||
wtCoal: begin
|
||||
if aNearAnyHouse then
|
||||
SeedLocs := GetSeeds([htAny])
|
||||
else
|
||||
if gHands[fOwner].Stats.GetHouseTotal(htCoalMine) > 0 then
|
||||
SeedLocs := GetSeeds([htCoalMine])
|
||||
else
|
||||
SeedLocs := GetSeeds([htStore]);
|
||||
if Length(SeedLocs) = 0 then Exit;
|
||||
if not FindNearest(SeedLocs[KaMRandom(Length(SeedLocs){$IFDEF DBG_RNG_SPY}, 'TKMCityPlanner.NextToOre'{$ENDIF})], 45, fnCoal, P) then
|
||||
if aNearAnyHouse or not NextToOre(aHouse, aOreType, P, True) then
|
||||
Exit;
|
||||
end;
|
||||
wtIronOre: begin
|
||||
if aNearAnyHouse then
|
||||
SeedLocs := GetSeeds([htAny])
|
||||
else
|
||||
if gHands[fOwner].Stats.GetHouseTotal(htIronMine) > 0 then
|
||||
SeedLocs := GetSeeds([htIronMine, htCoalMine])
|
||||
else
|
||||
SeedLocs := GetSeeds([htCoalMine, htStore]);
|
||||
if Length(SeedLocs) = 0 then Exit;
|
||||
if not FindNearest(SeedLocs[KaMRandom(Length(SeedLocs){$IFDEF DBG_RNG_SPY}, 'TKMCityPlanner.NextToOre_2'{$ENDIF})], 45, fnIron, P) then
|
||||
if aNearAnyHouse or not NextToOre(aHouse, aOreType, P, True) then
|
||||
Exit;
|
||||
end;
|
||||
wtGoldOre: begin
|
||||
if aNearAnyHouse then
|
||||
SeedLocs := GetSeeds([htAny])
|
||||
else
|
||||
if gHands[fOwner].Stats.GetHouseTotal(htGoldMine) > 0 then
|
||||
SeedLocs := GetSeeds([htGoldMine, htCoalMine])
|
||||
else
|
||||
SeedLocs := GetSeeds([htCoalMine, htStore]);
|
||||
if Length(SeedLocs) = 0 then Exit;
|
||||
if not FindNearest(SeedLocs[KaMRandom(Length(SeedLocs){$IFDEF DBG_RNG_SPY}, 'TKMCityPlanner.NextToOre_3'{$ENDIF})], 45, fnGold, P) then
|
||||
if aNearAnyHouse or not NextToOre(aHouse, aOreType, P, True) then
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
|
||||
//todo -cComplicated: If there's no ore AI should not keep calling this over and over again
|
||||
// Maybe AI can cache search results for such non-replenishing resources
|
||||
|
||||
aLoc := P;
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
|
||||
function TKMCityPlanner.NextToTrees(aHouse: TKMHouseType; aSeed: array of TKMHouseType; out aLoc: TKMPoint): Boolean;
|
||||
const
|
||||
SEARCH_RES = 7;
|
||||
SEARCH_RAD = 20; //Search for forests within this radius
|
||||
SEARCH_DIV = (SEARCH_RAD * 2) div SEARCH_RES + 1;
|
||||
HUT_RAD = 6; //Search for the best place for a hut in this radius
|
||||
var
|
||||
I, K: Integer;
|
||||
Bid, BestBid: Single;
|
||||
SeedLocs: TKMPointArray;
|
||||
seedLoc, TreeLoc: TKMPoint;
|
||||
Mx, My: SmallInt;
|
||||
MyForest: array [0..SEARCH_RES-1, 0..SEARCH_RES-1] of ShortInt;
|
||||
begin
|
||||
Result := False;
|
||||
|
||||
SeedLocs := GetSeeds(aSeed);
|
||||
if Length(SeedLocs) = 0 then Exit;
|
||||
|
||||
// Pick one random seed loc from given
|
||||
seedLoc := SeedLocs[KaMRandom(Length(SeedLocs){$IFDEF DBG_RNG_SPY}, 'TKMCityPlanner.NextToTrees'{$ENDIF})];
|
||||
|
||||
//todo -cComplicated: Rework through FindNearest to avoid roundabouts
|
||||
//Fill in MyForest map
|
||||
FillChar(MyForest[0,0], SizeOf(MyForest), #0);
|
||||
for I := Max(seedLoc.Y - SEARCH_RAD, 1) to Min(seedLoc.Y + SEARCH_RAD, gTerrain.MapY - 1) do
|
||||
for K := Max(seedLoc.X - SEARCH_RAD, 1) to Min(seedLoc.X + SEARCH_RAD, gTerrain.MapX - 1) do
|
||||
if gTerrain.ObjectIsChopableTree(K, I) then
|
||||
begin
|
||||
Mx := (K - seedLoc.X + SEARCH_RAD) div SEARCH_DIV;
|
||||
My := (I - seedLoc.Y + SEARCH_RAD) div SEARCH_DIV;
|
||||
|
||||
Inc(MyForest[My, Mx]);
|
||||
end;
|
||||
|
||||
//Find cell with most trees
|
||||
BestBid := -MaxSingle;
|
||||
TreeLoc := seedLoc; //Init incase we cant find a spot at all
|
||||
for I := Low(MyForest) to High(MyForest) do
|
||||
for K := Low(MyForest[I]) to High(MyForest[I]) do
|
||||
begin
|
||||
Mx := Round(seedLoc.X - SEARCH_RAD + (K + 0.5) * SEARCH_DIV);
|
||||
My := Round(seedLoc.Y - SEARCH_RAD + (I + 0.5) * SEARCH_DIV);
|
||||
if InRange(Mx, 1, gTerrain.MapX - 1) and InRange(My, 1, gTerrain.MapY - 1)
|
||||
and (gAIFields.Influences.AvoidBuilding[My, Mx] = 0) then
|
||||
begin
|
||||
Bid := MyForest[I, K] + KaMRandom({$IFDEF DBG_RNG_SPY}'TKMCityPlanner.NextToTrees_2'{$ENDIF}) * 2; //Add some noise for varied results
|
||||
if Bid > BestBid then
|
||||
begin
|
||||
TreeLoc := KMPoint(Mx, My);
|
||||
BestBid := Bid;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
BestBid := MaxSingle;
|
||||
for I := Max(TreeLoc.Y - HUT_RAD, 1) to Min(TreeLoc.Y + HUT_RAD, gTerrain.MapY - 1) do
|
||||
for K := Max(TreeLoc.X - HUT_RAD, 1) to Min(TreeLoc.X + HUT_RAD, gTerrain.MapX - 1) do
|
||||
if gHands[fOwner].CanAddHousePlanAI(K, I, aHouse, True) then
|
||||
begin
|
||||
Bid := KMLength(KMPoint(K,I), seedLoc) + KaMRandom({$IFDEF DBG_RNG_SPY}'TKMCityPlanner.NextToTrees_3'{$ENDIF}) * 5;
|
||||
if (Bid < BestBid) then
|
||||
begin
|
||||
aLoc := KMPoint(K,I);
|
||||
BestBid := Bid;
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCityPlanner.OwnerUpdate(aPlayer: TKMHandID);
|
||||
begin
|
||||
fOwner := aPlayer;
|
||||
fFinder.OwnerUpdate(fOwner);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCityPlanner.Save(SaveStream: TKMemoryStream);
|
||||
begin
|
||||
SaveStream.PlaceMarker('AICityPlanner');
|
||||
SaveStream.Write(fOwner);
|
||||
fFinder.Save(SaveStream);
|
||||
fListGold.SaveToStream(SaveStream);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCityPlanner.Load(LoadStream: TKMemoryStream);
|
||||
begin
|
||||
LoadStream.CheckMarker('AICityPlanner');
|
||||
LoadStream.Read(fOwner);
|
||||
fFinder.Load(LoadStream);
|
||||
fListGold.LoadFromStream(LoadStream);
|
||||
end;
|
||||
|
||||
|
||||
{ TKMTerrainFinderCity }
|
||||
constructor TKMTerrainFinderCity.Create(aOwner: TKMHandID);
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
fOwner := aOwner;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMTerrainFinderCity.OwnerUpdate(aPlayer: TKMHandID);
|
||||
begin
|
||||
fOwner := aPlayer;
|
||||
end;
|
||||
|
||||
|
||||
function TKMTerrainFinderCity.CanUse(const X, Y: Word): Boolean;
|
||||
var
|
||||
I, K: Integer;
|
||||
begin
|
||||
case FindType of
|
||||
fnHouse: Result := gHands[fOwner].CanAddHousePlanAI(X, Y, HouseType, True);
|
||||
|
||||
fnStone: Result := (gTerrain.TileIsStone(X, Max(Y-1, 1)) > 1);
|
||||
|
||||
fnCoal: Result := (gTerrain.TileIsCoal(X, Y) > 1)
|
||||
and gHands[fOwner].CanAddHousePlanAI(X, Y, htCoalMine, False);
|
||||
|
||||
fnIron: begin
|
||||
Result := gHands[fOwner].CanAddHousePlanAI(X, Y, htIronMine, False);
|
||||
//If we can build a mine here then search for ore
|
||||
if Result then
|
||||
for I:=Max(X-4, 1) to Min(X+3, gTerrain.MapX) do
|
||||
for K:=Max(Y-8, 1) to Y do
|
||||
if gTerrain.TileHasIron(I, K) then
|
||||
Exit;
|
||||
Result := False; //Didn't find any ore
|
||||
end;
|
||||
|
||||
fnGold: begin
|
||||
Result := gHands[fOwner].CanAddHousePlanAI(X, Y, htGoldMine, False);
|
||||
//If we can build a mine here then search for ore
|
||||
if Result then
|
||||
for I:=Max(X-4, 1) to Min(X+4, gTerrain.MapX) do
|
||||
for K:=Max(Y-8, 1) to Y do
|
||||
if gTerrain.TileHasGold(I, K) then
|
||||
Exit;
|
||||
Result := False; //Didn't find any ore
|
||||
end;
|
||||
|
||||
else Result := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMTerrainFinderCity.CanWalkHere(const X,Y: Word): Boolean;
|
||||
var
|
||||
TerOwner: TKMHandID;
|
||||
begin
|
||||
//Check for specific passabilities
|
||||
case FindType of
|
||||
fnIron: Result := (fPassability * gTerrain.Land^[Y,X].Passability <> [])
|
||||
or gTerrain.CanPlaceIronMine(X, Y);
|
||||
|
||||
fnGold: Result := (fPassability * gTerrain.Land^[Y,X].Passability <> [])
|
||||
or gTerrain.TileGoodForGoldmine(X, Y);
|
||||
|
||||
else Result := (fPassability * gTerrain.Land^[Y,X].Passability <> []);
|
||||
end;
|
||||
|
||||
if not Result then Exit;
|
||||
|
||||
//Don't build on allies and/or enemies territory
|
||||
TerOwner := gAIFields.Influences.GetBestOwner(X,Y);
|
||||
Result := ((TerOwner = fOwner) or (TerOwner = HAND_NONE));
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMTerrainFinderCity.Save(SaveStream: TKMemoryStream);
|
||||
begin
|
||||
inherited;
|
||||
SaveStream.PlaceMarker('TerrainFinderCity');
|
||||
SaveStream.Write(fOwner);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMTerrainFinderCity.Load(LoadStream: TKMemoryStream);
|
||||
begin
|
||||
inherited;
|
||||
LoadStream.CheckMarker('TerrainFinderCity');
|
||||
LoadStream.Read(fOwner);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
+525
@@ -0,0 +1,525 @@
|
||||
unit KM_AIDefensePos;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Math,
|
||||
KM_Entity, KM_UnitGroup,
|
||||
KM_CommonClasses, KM_Defaults, KM_Points,
|
||||
KM_AITypes;
|
||||
|
||||
|
||||
type
|
||||
TAIDefencePosition = class(TKMEntity)
|
||||
private
|
||||
fDefenceType: TKMAIDefencePosType; //Whether this is a front or back line defence position. See comments on TAIDefencePosType above
|
||||
fGroupType: TKMGroupType; //Type of group to defend this position (e.g. melee)
|
||||
fPosition: TKMPointDir; //Position and direction the group defending will stand
|
||||
fRadius: Integer; //If fighting (or houses being attacked) occurs within this radius from this defence position, this group will get involved
|
||||
|
||||
fCurrentGroup: TKMUnitGroup; //Commander of group currently occupying position
|
||||
procedure SetCurrentGroup(aGroup: TKMUnitGroup);
|
||||
procedure SetGroupType(const Value: TKMGroupType);
|
||||
procedure SetDefenceType(const Value: TKMAIDefencePosType);
|
||||
procedure SetPosition(const Value: TKMPointDir);
|
||||
public
|
||||
constructor Create(aUID: Integer; const aPos: TKMPointDir; aGroupType: TKMGroupType; aRadius: Integer; aDefenceType: TKMAIDefencePosType);
|
||||
constructor Load(LoadStream: TKMemoryStream); override;
|
||||
destructor Destroy; override;
|
||||
|
||||
property DefenceType: TKMAIDefencePosType read fDefenceType write SetDefenceType;
|
||||
property GroupType: TKMGroupType read fGroupType write SetGroupType; //Type of group to defend this position (e.g. melee)
|
||||
property Position: TKMPointDir read fPosition write SetPosition; //Position and direction the group defending will stand
|
||||
property Radius: Integer read fRadius write fRadius; //If fighting (or houses being attacked) occurs within this radius from this defence position, this group will get involved
|
||||
|
||||
property CurrentGroup: TKMUnitGroup read fCurrentGroup write SetCurrentGroup;
|
||||
function CanAccept(aGroup: TKMUnitGroup; aMaxUnits: Integer): Boolean;
|
||||
procedure Save(SaveStream: TKMemoryStream); override;
|
||||
procedure SyncLoad;
|
||||
procedure UpdateState;
|
||||
end;
|
||||
|
||||
|
||||
TAIDefencePositions = class
|
||||
private
|
||||
fOwner: TKMHandID;
|
||||
fPositions: TKMList;
|
||||
function GetPosition(aIndex: Integer): TAIDefencePosition; inline;
|
||||
function GetCount: Integer; inline;
|
||||
function CreateDefPosition(const aPos: TKMPointDir; aGroupType: TKMGroupType; aRadius: Integer; aDefenceType: TKMAIDefencePosType): TAIDefencePosition;
|
||||
public
|
||||
//Defines how defending troops will be formatted. 0 means leave unchanged.
|
||||
TroopFormations: array [GROUP_TYPE_MIN..GROUP_TYPE_MAX] of TKMFormation;
|
||||
|
||||
constructor Create(aPlayer: TKMHandID);
|
||||
destructor Destroy; override;
|
||||
|
||||
function Add(const aPos: TKMPointDir; aGroupType: TKMGroupType; aRadius: Integer; aDefenceType: TKMAIDefencePosType): Integer;
|
||||
function Insert(aIndex: Integer; const aPos: TKMPointDir; aGroupType: TKMGroupType; aRadius: Integer; aDefenceType: TKMAIDefencePosType): Integer;
|
||||
procedure Clear;
|
||||
property Count: Integer read GetCount;
|
||||
procedure Delete(aIndex: Integer);
|
||||
property Positions[aIndex: Integer]: TAIDefencePosition read GetPosition; default;
|
||||
function GetBacklineCount: Integer;
|
||||
function AverageUnitsPerGroup: Integer;
|
||||
|
||||
function FindPlaceForGroup(aGroup: TKMUnitGroup; aTakeClosest: Boolean): Boolean;
|
||||
|
||||
function FindPositionAtLoc(aPos: TKMPoint ): TAIDefencePosition;
|
||||
|
||||
procedure RestockPositionWith(aDefenceGroup, aGroup: TKMUnitGroup);
|
||||
function FindPositionOf(aGroup: TKMUnitGroup): TAIDefencePosition;
|
||||
procedure GetArmyDemand(out aFootmen: Integer; out aPikemen: Integer; out aHorsemen: Integer; out aArchers: Integer);
|
||||
|
||||
procedure MoveUp(aIndex: Integer);
|
||||
procedure MoveDown(aIndex: Integer);
|
||||
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure Load(LoadStream: TKMemoryStream);
|
||||
procedure SyncLoad;
|
||||
procedure UpdateState;
|
||||
procedure Paint;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
SysUtils, TypInfo,
|
||||
KM_Game, KM_GameUIDTracker, KM_GameParams, KM_HandsCollection, KM_RenderAux, KM_RenderPool, KM_Hand,
|
||||
KM_UnitGroupTypes, KM_InterfaceGame;
|
||||
|
||||
|
||||
{ TAIDefencePosition }
|
||||
constructor TAIDefencePosition.Create(aUID: Integer; const aPos: TKMPointDir; aGroupType: TKMGroupType; aRadius: Integer; aDefenceType: TKMAIDefencePosType);
|
||||
begin
|
||||
inherited Create(aUID);
|
||||
|
||||
Assert(aGroupType in GROUP_TYPES_VALID, 'Invalid group type: ' + GetEnumName(TypeInfo(TKMGroupType), Integer(aGroupType)));
|
||||
fPosition := aPos;
|
||||
fGroupType := aGroupType;
|
||||
fRadius := aRadius;
|
||||
fDefenceType := aDefenceType;
|
||||
CurrentGroup := nil; //Unoccupied
|
||||
end;
|
||||
|
||||
|
||||
destructor TAIDefencePosition.Destroy;
|
||||
begin
|
||||
CurrentGroup := nil; //Ensure pointer is removed
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePosition.SetCurrentGroup(aGroup: TKMUnitGroup);
|
||||
begin
|
||||
//Release previous group
|
||||
gHands.CleanUpGroupPointer(fCurrentGroup);
|
||||
|
||||
//Take new one
|
||||
if aGroup <> nil then
|
||||
fCurrentGroup := aGroup.GetPointer;
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePosition.SetDefenceType(const Value: TKMAIDefencePosType);
|
||||
begin
|
||||
Assert(gGameParams.IsMapEditor);
|
||||
fDefenceType := Value;
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePosition.SetGroupType(const Value: TKMGroupType);
|
||||
begin
|
||||
Assert(gGameParams.IsMapEditor);
|
||||
Assert(Value in GROUP_TYPES_VALID, 'Invalid group type: ' + GetEnumName(TypeInfo(TKMGroupType), Integer(Value)));
|
||||
fGroupType := Value;
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePosition.SetPosition(const Value: TKMPointDir);
|
||||
begin
|
||||
Assert(gGameParams.IsMapEditor);
|
||||
fPosition := Value;
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePosition.Save(SaveStream: TKMemoryStream);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
SaveStream.PlaceMarker('ClsDefencePos');
|
||||
SaveStream.Write(fPosition);
|
||||
SaveStream.Write(fGroupType, SizeOf(fGroupType));
|
||||
SaveStream.Write(fRadius);
|
||||
SaveStream.Write(fDefenceType, SizeOf(fDefenceType));
|
||||
SaveStream.Write(fCurrentGroup.UID); //Store ID
|
||||
end;
|
||||
|
||||
|
||||
constructor TAIDefencePosition.Load(LoadStream: TKMemoryStream);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
LoadStream.CheckMarker('ClsDefencePos');
|
||||
LoadStream.Read(fPosition);
|
||||
LoadStream.Read(fGroupType, SizeOf(fGroupType));
|
||||
LoadStream.Read(fRadius);
|
||||
LoadStream.Read(fDefenceType, SizeOf(fDefenceType));
|
||||
LoadStream.Read(fCurrentGroup, 4); //subst on syncload
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePosition.SyncLoad;
|
||||
begin
|
||||
fCurrentGroup := gHands.GetGroupByUID(Integer(fCurrentGroup));
|
||||
end;
|
||||
|
||||
|
||||
function TAIDefencePosition.CanAccept(aGroup: TKMUnitGroup; aMaxUnits: Integer): Boolean;
|
||||
begin
|
||||
Result := (fGroupType = UNIT_TO_GROUP_TYPE[aGroup.UnitType]);
|
||||
|
||||
if not Result then Exit;
|
||||
|
||||
// Empty position accepts anything (e.g. happens at mission start)
|
||||
// As checked in KaM - it did not link big groups to filled Positions
|
||||
Result := (CurrentGroup = nil) or
|
||||
(aGroup.Count = 1);
|
||||
|
||||
Result := Result and ((CurrentGroup = nil) or (CurrentGroup.Count < aMaxUnits));
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePosition.UpdateState;
|
||||
begin
|
||||
//If the group is Dead or too far away we should disassociate
|
||||
//them from the defence position so new warriors can take up the defence if needs be
|
||||
if (CurrentGroup = nil)
|
||||
or CurrentGroup.IsDead
|
||||
or ((CurrentGroup.InFight or (CurrentGroup.Order in [goAttackHouse, goAttackUnit]))
|
||||
and (KMLengthDiag(Position.Loc, CurrentGroup.Position) > Radius)) then
|
||||
CurrentGroup := nil;
|
||||
|
||||
//Tell group to walk to its position
|
||||
//It's easier to repeat the order than check that all members are in place
|
||||
if (CurrentGroup <> nil)
|
||||
and CurrentGroup.IsIdleToAI([wtokFlagPoint, wtokHaltOrder])
|
||||
and CurrentGroup.CanWalkTo(Position.Loc, 0) then
|
||||
CurrentGroup.OrderWalk(Position.Loc, True, wtokAIGotoDefencePos, Position.Dir);
|
||||
end;
|
||||
|
||||
|
||||
{ TAIDefencePositions }
|
||||
constructor TAIDefencePositions.Create(aPlayer: TKMHandID);
|
||||
var
|
||||
GT: TKMGroupType;
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
fOwner := aPlayer;
|
||||
fPositions := TKMList.Create;
|
||||
|
||||
for GT := GROUP_TYPE_MIN to GROUP_TYPE_MAX do
|
||||
begin
|
||||
TroopFormations[GT].NumUnits := 9; //These are the defaults in KaM
|
||||
TroopFormations[GT].UnitsPerRow := 3;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
destructor TAIDefencePositions.Destroy;
|
||||
begin
|
||||
fPositions.Free;
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
function TAIDefencePositions.GetCount: Integer;
|
||||
begin
|
||||
Result := fPositions.Count;
|
||||
end;
|
||||
|
||||
|
||||
//Find DefencePosition at location
|
||||
function TAIDefencePositions.FindPositionAtLoc(aPos: TKMPoint): TAIDefencePosition;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
Result := nil;
|
||||
|
||||
for I := 0 to Count - 1 do
|
||||
if Positions[I].Position.Loc = aPos then
|
||||
Exit(Positions[I]);
|
||||
end;
|
||||
|
||||
|
||||
function TAIDefencePositions.GetPosition(aIndex: Integer): TAIDefencePosition;
|
||||
begin
|
||||
if not InRange(aIndex, 0, Count - 1) then Exit(nil);
|
||||
|
||||
Result := fPositions[aIndex];
|
||||
end;
|
||||
|
||||
|
||||
function TAIDefencePositions.CreateDefPosition(const aPos: TKMPointDir; aGroupType: TKMGroupType; aRadius: Integer; aDefenceType: TKMAIDefencePosType): TAIDefencePosition;
|
||||
begin
|
||||
Assert(aGroupType in GROUP_TYPES_VALID, 'Invalid group type: ' + GetEnumName(TypeInfo(TKMGroupType), Integer(aGroupType)));
|
||||
|
||||
Result := TAIDefencePosition.Create(gUIDTracker.GetNewUID, aPos, aGroupType, aRadius, aDefenceType);
|
||||
end;
|
||||
|
||||
|
||||
function TAIDefencePositions.Add(const aPos: TKMPointDir; aGroupType: TKMGroupType; aRadius: Integer; aDefenceType: TKMAIDefencePosType): Integer;
|
||||
var
|
||||
defPos: TAIDefencePosition;
|
||||
begin
|
||||
defPos := CreateDefPosition(aPos, aGroupType, aRadius, aDefenceType);
|
||||
fPositions.Add(defPos);
|
||||
Result := defPos.UID;
|
||||
end;
|
||||
|
||||
|
||||
function TAIDefencePositions.Insert(aIndex: Integer; const aPos: TKMPointDir; aGroupType: TKMGroupType; aRadius: Integer; aDefenceType: TKMAIDefencePosType): Integer;
|
||||
var
|
||||
defPos: TAIDefencePosition;
|
||||
begin
|
||||
Assert(InRange(aIndex, 0, Count), 'Can''t insert defence position at position ' + IntToStr(aIndex));
|
||||
defPos := CreateDefPosition(aPos, aGroupType, aRadius, aDefenceType);
|
||||
|
||||
fPositions.Insert(aIndex, defPos);
|
||||
|
||||
Result := defPos.UID;
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePositions.Clear;
|
||||
begin
|
||||
fPositions.Clear;
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePositions.Delete(aIndex: Integer);
|
||||
begin
|
||||
//Note: Order of positions is important (AI fills them with troops from 0 to N)
|
||||
fPositions.Delete(aIndex);
|
||||
end;
|
||||
|
||||
|
||||
function TAIDefencePositions.GetBacklineCount: Integer;
|
||||
var I: Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
for I := 0 to Count - 1 do
|
||||
if Positions[I].fDefenceType = dtBackLine then
|
||||
Inc(Result);
|
||||
end;
|
||||
|
||||
|
||||
function TAIDefencePositions.AverageUnitsPerGroup: Integer;
|
||||
var
|
||||
GT: TKMGroupType;
|
||||
TypeCount: Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
TypeCount := 0;
|
||||
for GT := GROUP_TYPE_MIN to GROUP_TYPE_MAX do
|
||||
begin
|
||||
Result := Result + TroopFormations[GT].NumUnits;
|
||||
Inc(TypeCount);
|
||||
end;
|
||||
Result := Result div TypeCount;
|
||||
end;
|
||||
|
||||
|
||||
function TAIDefencePositions.FindPlaceForGroup(aGroup: TKMUnitGroup; aTakeClosest: Boolean): Boolean;
|
||||
var
|
||||
I, Matched: Integer;
|
||||
Distance, Best: Single;
|
||||
begin
|
||||
Result := False;
|
||||
Matched := -1;
|
||||
Best := MaxSingle;
|
||||
|
||||
//Try to link to existing group
|
||||
for I := 0 to Count - 1 do
|
||||
if Positions[I].CanAccept(aGroup, TroopFormations[aGroup.GroupType].NumUnits) then
|
||||
begin
|
||||
//Take closest position that is empty or requries restocking
|
||||
Distance := KMLengthSqr(aGroup.Position, Positions[I].Position.Loc);
|
||||
if Distance < Best then
|
||||
begin
|
||||
Matched := I;
|
||||
Best := Distance;
|
||||
//KaM fills defence positions by their order of creation
|
||||
//Take first one we find - that's what KaM does
|
||||
if not aTakeClosest then Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
if Matched <> -1 then
|
||||
begin
|
||||
Result := True;
|
||||
if Positions[Matched].CurrentGroup = nil then
|
||||
begin
|
||||
//New position
|
||||
Positions[Matched].CurrentGroup := aGroup;
|
||||
if aGroup.UnitsPerRow < TroopFormations[aGroup.GroupType].UnitsPerRow then
|
||||
aGroup.UnitsPerRow := TroopFormations[aGroup.GroupType].UnitsPerRow;
|
||||
aGroup.OrderWalk(Positions[Matched].Position.Loc, True, wtokAIGotoDefencePos);
|
||||
end
|
||||
else
|
||||
//Append to existing position
|
||||
RestockPositionWith(Positions[Matched].CurrentGroup, aGroup);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePositions.RestockPositionWith(aDefenceGroup, aGroup: TKMUnitGroup);
|
||||
var
|
||||
Needed: integer;
|
||||
begin
|
||||
Needed := TroopFormations[aDefenceGroup.GroupType].NumUnits - aDefenceGroup.Count;
|
||||
if Needed <= 0 then exit;
|
||||
if aGroup.Count <= Needed then
|
||||
aGroup.OrderLinkTo(aDefenceGroup, True) //Link entire group
|
||||
else
|
||||
aGroup.OrderSplitLinkTo(aDefenceGroup, Needed, True); //Link only as many units as are needed
|
||||
|
||||
if aDefenceGroup.UnitsPerRow < TroopFormations[aDefenceGroup.GroupType].UnitsPerRow then
|
||||
aDefenceGroup.UnitsPerRow := TroopFormations[aDefenceGroup.GroupType].UnitsPerRow;
|
||||
end;
|
||||
|
||||
|
||||
//Find DefencePosition to which this Commander belongs
|
||||
//(Result could be nil if CommanderCount > PositionsCount
|
||||
function TAIDefencePositions.FindPositionOf(aGroup: TKMUnitGroup): TAIDefencePosition;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
Result := nil;
|
||||
|
||||
for I := 0 to Count - 1 do
|
||||
if Positions[I].CurrentGroup = aGroup then
|
||||
begin
|
||||
Result := Positions[I];
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePositions.GetArmyDemand(out aFootmen: Integer; out aPikemen: Integer; out aHorsemen: Integer; out aArchers: Integer);
|
||||
var I, Required: Integer;
|
||||
begin
|
||||
aFootmen := 0;
|
||||
aPikemen := 0;
|
||||
aHorsemen := 0;
|
||||
aArchers := 0;
|
||||
for I := 0 to Count - 1 do
|
||||
begin
|
||||
Required := TroopFormations[Positions[I].GroupType].NumUnits;
|
||||
case Positions[I].GroupType of
|
||||
gtMelee: Inc(aFootmen, Required);
|
||||
gtAntiHorse: Inc(aPikemen, Required);
|
||||
gtRanged: Inc(aArchers, Required);
|
||||
gtMounted: Inc(aHorsemen, Required);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePositions.MoveUp(aIndex: Integer);
|
||||
begin
|
||||
if aIndex < Count-1 then
|
||||
fPositions.Exchange(aIndex, aIndex+1);
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePositions.MoveDown(aIndex: Integer);
|
||||
begin
|
||||
if aIndex > 0 then
|
||||
fPositions.Exchange(aIndex, aIndex-1);
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePositions.Save(SaveStream: TKMemoryStream);
|
||||
var I: Integer;
|
||||
begin
|
||||
SaveStream.PlaceMarker('ClsDefencePositions');
|
||||
SaveStream.Write(fOwner);
|
||||
SaveStream.Write(TroopFormations, SizeOf(TroopFormations));
|
||||
SaveStream.Write(Count);
|
||||
|
||||
for I := 0 to Count - 1 do
|
||||
Positions[I].Save(SaveStream);
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePositions.Load(LoadStream: TKMemoryStream);
|
||||
var I, NewCount: Integer;
|
||||
begin
|
||||
LoadStream.CheckMarker('ClsDefencePositions');
|
||||
LoadStream.Read(fOwner);
|
||||
LoadStream.Read(TroopFormations, SizeOf(TroopFormations));
|
||||
LoadStream.Read(NewCount);
|
||||
|
||||
for I := 0 to NewCount - 1 do
|
||||
fPositions.Add(TAIDefencePosition.Load(LoadStream));
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePositions.SyncLoad;
|
||||
var I: Integer;
|
||||
begin
|
||||
for I := 0 to Count - 1 do
|
||||
Positions[I].SyncLoad;
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePositions.UpdateState;
|
||||
var I,K: Integer;
|
||||
begin
|
||||
//Make sure no defence position Group is dead
|
||||
for I := 0 to Count - 1 do
|
||||
Positions[I].UpdateState;
|
||||
|
||||
//In KaM the order of defence positions is the priority: The first defined is higher priority
|
||||
for I := 0 to Count - 1 do
|
||||
if (Positions[I].CurrentGroup = nil) then
|
||||
for K := I + 1 to Count - 1 do
|
||||
if Positions[I].GroupType = Positions[K].GroupType then
|
||||
begin
|
||||
Positions[I].CurrentGroup := Positions[K].CurrentGroup; //Take new position
|
||||
Positions[K].CurrentGroup := nil; //Leave current position
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TAIDefencePositions.Paint;
|
||||
var
|
||||
I: Integer;
|
||||
str: string;
|
||||
begin
|
||||
for I := 0 to Count - 1 do
|
||||
begin
|
||||
gRenderAux.Quad(Positions[I].Position.Loc.X, Positions[I].fPosition.Loc.Y, DEFENCE_LINE_TYPE_COL[Positions[I].fDefenceType]);
|
||||
|
||||
gRenderPool.RenderSpriteOnTile(Positions[I].Position.Loc, 510 + Byte(Positions[I].Position.Dir), gHands[fOwner].FlagColor);
|
||||
gRenderAux.CircleOnTerrain(Positions[I].Position.Loc.X-0.5, Positions[I].Position.Loc.Y-0.5, Positions[I].Radius,
|
||||
gHands[fOwner].FlagColor AND $08FFFFFF,
|
||||
gHands[fOwner].FlagColor);
|
||||
//group type and position number will be painted by InterfaceMapEditor
|
||||
|
||||
if not gGameParams.IsMapEditor then
|
||||
begin
|
||||
str := 'nil';
|
||||
if Positions[I].CurrentGroup <> nil then
|
||||
str := IntToStr(Positions[I].CurrentGroup.UID);
|
||||
|
||||
gRenderAux.Text(Positions[I].fPosition.Loc.X, Positions[I].fPosition.Loc.Y, str, icRed);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
+162
@@ -0,0 +1,162 @@
|
||||
unit KM_AIFields;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
KM_NavMesh, KM_AIInfluences, KM_Eye, KM_Supervisor,
|
||||
KM_CommonClasses, KM_Points, KM_GameTypes;
|
||||
|
||||
|
||||
type
|
||||
//Master class for Influence maps, NavMeshe and other terrain representations
|
||||
//that are helpful in decision making by Mayour/General
|
||||
TKMAIFields = class
|
||||
private
|
||||
fNavMesh: TKMNavMesh;
|
||||
fInfluences: TKMInfluences;
|
||||
fEye: TKMEye;
|
||||
fSupervisor: TKMSupervisor;
|
||||
|
||||
fCanHaveAAI: Boolean; // Flag, if game can have AdvancedAI
|
||||
public
|
||||
constructor Create();
|
||||
destructor Destroy(); override;
|
||||
|
||||
property NavMesh: TKMNavMesh read fNavMesh;
|
||||
property Influences: TKMInfluences read fInfluences;
|
||||
property Eye: TKMEye read fEye write fEye;
|
||||
property Supervisor: TKMSupervisor read fSupervisor write fSupervisor;
|
||||
|
||||
procedure AfterMissionInit(aCanHaveAAI: Boolean);
|
||||
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure Load(LoadStream: TKMemoryStream);
|
||||
procedure UpdateState(aTick: Cardinal);
|
||||
procedure Paint(const aRect: TKMRect);
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
gAIFields: TKMAIFields;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
SysUtils,
|
||||
KM_Defaults,
|
||||
KM_DevPerfLog, KM_DevPerfLogTypes;
|
||||
|
||||
const
|
||||
AIFIELDS_MARKER = 'AIFields';
|
||||
|
||||
|
||||
{ TKMAIFields }
|
||||
constructor TKMAIFields.Create();
|
||||
begin
|
||||
inherited;
|
||||
|
||||
fNavMesh := TKMNavMesh.Create();
|
||||
fInfluences := TKMInfluences.Create(fNavMesh);
|
||||
fEye := TKMEye.Create();
|
||||
fSupervisor := TKMSupervisor.Create();
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMAIFields.Destroy();
|
||||
begin
|
||||
FreeAndNil(fNavMesh);
|
||||
FreeAndNil(fInfluences);
|
||||
FreeAndNil(fEye);
|
||||
FreeAndNil(fSupervisor);
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAIFields.AfterMissionInit(aCanHaveAAI: Boolean);
|
||||
begin
|
||||
fCanHaveAAI := aCanHaveAAI;
|
||||
|
||||
if not FEAT_AI_GENERATE_NAVMESH then
|
||||
Exit;
|
||||
|
||||
fNavMesh.AfterMissionInit();
|
||||
fInfluences.AfterMissionInit();
|
||||
if fCanHaveAAI then
|
||||
begin
|
||||
fSupervisor.AfterMissionInit();
|
||||
// fEye.AfterMissionInit(); Eye is updated from HandsCollection (so mines are already visible for game with random map and automatic selection of storehouse)
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAIFields.Save(SaveStream: TKMemoryStream);
|
||||
begin
|
||||
SaveStream.PlaceMarker(AIFIELDS_MARKER);
|
||||
|
||||
SaveStream.Write(fCanHaveAAI);
|
||||
fNavMesh.Save(SaveStream);
|
||||
fInfluences.Save(SaveStream);
|
||||
|
||||
if fCanHaveAAI then
|
||||
begin
|
||||
fEye.Save(SaveStream);
|
||||
fSupervisor.Save(SaveStream);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAIFields.Load(LoadStream: TKMemoryStream);
|
||||
begin
|
||||
LoadStream.CheckMarker(AIFIELDS_MARKER);
|
||||
|
||||
LoadStream.Read(fCanHaveAAI);
|
||||
fNavMesh.Load(LoadStream);
|
||||
fInfluences.Load(LoadStream);
|
||||
|
||||
if fCanHaveAAI then
|
||||
begin
|
||||
fEye.Load(LoadStream);
|
||||
fSupervisor.Load(LoadStream);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMAIFields.UpdateState(aTick: Cardinal);
|
||||
begin
|
||||
{$IFDEF DBG_PERFLOG}
|
||||
gPerfLogs.SectionEnter(psAIFields);
|
||||
{$ENDIF}
|
||||
try
|
||||
fNavMesh.UpdateState(aTick);
|
||||
fInfluences.UpdateState(aTick);
|
||||
|
||||
if fCanHaveAAI then
|
||||
begin
|
||||
fEye.UpdateState(aTick);
|
||||
fSupervisor.UpdateState(aTick);
|
||||
end;
|
||||
finally
|
||||
{$IFDEF DBG_PERFLOG}
|
||||
gPerfLogs.SectionLeave(psAIFields);
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
//Render debug symbols
|
||||
procedure TKMAIFields.Paint(const aRect: TKMRect);
|
||||
begin
|
||||
if FEAT_AI_GENERATE_INFLUENCE then
|
||||
fInfluences.Paint(aRect);
|
||||
|
||||
if FEAT_AI_GENERATE_NAVMESH then
|
||||
fNavMesh.Paint(aRect);
|
||||
|
||||
if fCanHaveAAI then
|
||||
begin
|
||||
fEye.Paint(aRect);
|
||||
fSupervisor.Paint(aRect);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
+813
@@ -0,0 +1,813 @@
|
||||
unit KM_AIGeneral;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Generics.Collections,
|
||||
KM_AISetup, KM_AIAttacks, KM_AIDefensePos,
|
||||
KM_Units, KM_UnitGroup, KM_UnitWarrior,
|
||||
KM_CommonClasses, KM_Defaults, KM_Points,
|
||||
KM_NavMeshDefences,
|
||||
KM_AITypes;
|
||||
|
||||
|
||||
type
|
||||
TKMGeneral = class
|
||||
private
|
||||
fLastEquippedTimeIron, fLastEquippedTimeLeather: Cardinal;
|
||||
fUnitsEquipOrdered: TDictionary<Integer, TKMUnitWarrior>; //Units for which AIGeneral ordered to equip, but who did not exits the barracks yet
|
||||
|
||||
fOwner: TKMHandID;
|
||||
fSetup: TKMHandAISetup;
|
||||
fAttacks: TKMAIAttacks;
|
||||
fDefencePositions: TAIDefencePositions;
|
||||
|
||||
procedure CheckArmy;
|
||||
procedure CheckArmyCount;
|
||||
procedure CheckAttacks;
|
||||
procedure CheckAutoAttack;
|
||||
procedure CheckAutoDefend;
|
||||
procedure OrderAttack(aGroup: TKMUnitGroup; aTarget: TKMAIAttackTarget; const aCustomPos: TKMPoint);
|
||||
|
||||
procedure RemoveEquipOrderedWarrior(aWarrior: TKMUnitWarrior);
|
||||
public
|
||||
constructor Create(aPlayer: TKMHandID; aSetup: TKMHandAISetup);
|
||||
destructor Destroy; override;
|
||||
|
||||
procedure AfterMissionInit;
|
||||
procedure OwnerUpdate(aPlayer: TKMHandID);
|
||||
property Attacks: TKMAIAttacks read fAttacks;
|
||||
property DefencePositions: TAIDefencePositions read fDefencePositions;
|
||||
procedure RetaliateAgainstThreat(aAttacker: TKMUnit);
|
||||
procedure WarriorEquipped(aWarrior: TKMUnitWarrior);
|
||||
procedure WarriorDied(aWarrior: TKMUnitWarrior);
|
||||
|
||||
procedure UpdateState(aTick: Cardinal);
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure Load(LoadStream: TKMemoryStream);
|
||||
procedure SyncLoad;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Classes, Math,
|
||||
KM_Entity,
|
||||
KM_Game, KM_GameParams,
|
||||
KM_Hand, KM_HandsCollection, KM_HandTypes, KM_HandEntity,
|
||||
KM_Terrain, KM_AIFields,
|
||||
KM_Houses, KM_HouseBarracks,
|
||||
KM_ResHouses, KM_CommonUtils, KM_DevPerfLog, KM_DevPerfLogTypes,
|
||||
KM_UnitGroupTypes,
|
||||
KM_ResTypes
|
||||
{$IFDEF FPC}
|
||||
, KM_Sort
|
||||
{$ENDIF}
|
||||
;
|
||||
|
||||
|
||||
const
|
||||
//For compatibility with KaM these must be False. We can add a !REMAKE_AI command later
|
||||
//to make them more "intelligent", but for now these are required for the campaigns to be playable.
|
||||
|
||||
//On the other hand, no need to reproduce KaM's flaws, so fill closest defence
|
||||
//positions for idle groups to avoid swapping on mission start. This shouldn't
|
||||
//cause incorrect behaviour in campaigns since either way the priority order
|
||||
//of positions will be respected.
|
||||
|
||||
AI_FILL_CLOSEST_IDLE = True;
|
||||
AI_FILL_CLOSEST_EQUIPPED = False;
|
||||
AI_LINK_IDLE = False;
|
||||
|
||||
|
||||
{ TKMGeneral }
|
||||
constructor TKMGeneral.Create(aPlayer: TKMHandID; aSetup: TKMHandAISetup);
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
fOwner := aPlayer;
|
||||
fSetup := aSetup;
|
||||
|
||||
fAttacks := TKMAIAttacks.Create;
|
||||
fDefencePositions := TAIDefencePositions.Create(aPlayer);
|
||||
|
||||
fUnitsEquipOrdered := TDictionary<Integer, TKMUnitWarrior>.Create;
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMGeneral.Destroy;
|
||||
var
|
||||
U, U2: TKMUnit;
|
||||
begin
|
||||
for U in fUnitsEquipOrdered.Values do
|
||||
begin
|
||||
U2 := U;
|
||||
gHands.CleanUpUnitPointer(U2);
|
||||
end;
|
||||
|
||||
fUnitsEquipOrdered.Free;
|
||||
fDefencePositions.Free;
|
||||
fAttacks.Free;
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGeneral.AfterMissionInit;
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGeneral.OwnerUpdate(aPlayer: TKMHandID);
|
||||
begin
|
||||
fOwner := aPlayer;
|
||||
end;
|
||||
|
||||
function CompareKeys(const aKey1, aKey2): Integer;
|
||||
var
|
||||
k1: Integer absolute aKey1;
|
||||
k2: Integer absolute aKey2;
|
||||
begin
|
||||
if k1 < k2 then Result := -1
|
||||
else if k1 > k2 then Result := +1
|
||||
else Result := 0;
|
||||
end;
|
||||
|
||||
procedure TKMGeneral.Save(SaveStream: TKMemoryStream);
|
||||
var
|
||||
uid: Integer;
|
||||
keyArray: TArray<Integer>;
|
||||
begin
|
||||
SaveStream.PlaceMarker('AIGeneral');
|
||||
SaveStream.Write(fOwner);
|
||||
SaveStream.Write(fLastEquippedTimeIron);
|
||||
SaveStream.Write(fLastEquippedTimeLeather);
|
||||
fAttacks.Save(SaveStream);
|
||||
fDefencePositions.Save(SaveStream);
|
||||
|
||||
SaveStream.PlaceMarker('AIGeneral_unitsEquipOrdered');
|
||||
SaveStream.Write(fUnitsEquipOrdered.Count);
|
||||
keyArray := fUnitsEquipOrdered.Keys.ToArray;
|
||||
{$IFNDEF FPC}
|
||||
TArray.Sort<Integer>(keyArray);
|
||||
{$ELSE}
|
||||
SortCustom(keyArray, Low(keyArray), High(keyArray), SizeOf(keyArray[0]), CompareKeys);
|
||||
{$ENDIF}
|
||||
|
||||
for uid in keyArray do
|
||||
SaveStream.Write(uid);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGeneral.Load(LoadStream: TKMemoryStream);
|
||||
var
|
||||
I, count, uid: Integer;
|
||||
begin
|
||||
LoadStream.CheckMarker('AIGeneral');
|
||||
LoadStream.Read(fOwner);
|
||||
LoadStream.Read(fLastEquippedTimeIron);
|
||||
LoadStream.Read(fLastEquippedTimeLeather);
|
||||
fAttacks.Load(LoadStream);
|
||||
fDefencePositions.Load(LoadStream);
|
||||
|
||||
LoadStream.CheckMarker('AIGeneral_unitsEquipOrdered');
|
||||
fUnitsEquipOrdered.Clear;
|
||||
LoadStream.Read(count);
|
||||
for I := 0 to Count - 1 do
|
||||
begin
|
||||
LoadStream.Read(uid);
|
||||
fUnitsEquipOrdered.Add(uid, nil);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGeneral.SyncLoad;
|
||||
var
|
||||
uid: Integer;
|
||||
begin
|
||||
fDefencePositions.SyncLoad;
|
||||
|
||||
for uid in fUnitsEquipOrdered.Keys do
|
||||
fUnitsEquipOrdered[uid] := TKMUnitWarrior(gHands.GetUnitByUID(Integer(uid)));
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGeneral.CheckArmyCount;
|
||||
|
||||
function CanEquipIron: Boolean;
|
||||
begin
|
||||
Result := not (fSetup.ArmyType = atLeather)
|
||||
AND (fSetup.UnlimitedEquip or gGame.CheckTime(fLastEquippedTimeIron + fSetup.EquipRateIron));
|
||||
end;
|
||||
|
||||
function CanEquipLeather: Boolean;
|
||||
begin
|
||||
Result := not (fSetup.ArmyType = atIron)
|
||||
AND (fSetup.UnlimitedEquip or gGame.CheckTime(fLastEquippedTimeLeather + fSetup.EquipRateLeather));
|
||||
end;
|
||||
|
||||
var
|
||||
Barracks: array of TKMHouseBarracks;
|
||||
HB: TKMHouseBarracks;
|
||||
GT: TKMGroupType;
|
||||
I,K: Integer;
|
||||
UT: TKMUnitType;
|
||||
GroupReq: TKMGroupTypeArray;
|
||||
warrior: TKMUnitWarrior;
|
||||
begin
|
||||
if gGame.IsPeaceTime then Exit; //Do not train soldiers during peacetime
|
||||
|
||||
//Don't train if we have reached our limit
|
||||
if (fSetup.MaxSoldiers <> -1) and (gHands[fOwner].Stats.GetArmyCount >= fSetup.MaxSoldiers) then
|
||||
Exit;
|
||||
|
||||
if not CanEquipIron and not CanEquipLeather then Exit;
|
||||
|
||||
//Create a list of troops that need to be trained based on defence position requirements
|
||||
FillChar(GroupReq, SizeOf(GroupReq), #0); //Clear up
|
||||
for I := 0 to fDefencePositions.Count - 1 do
|
||||
with fDefencePositions[I] do
|
||||
if CurrentGroup = nil then
|
||||
Inc(GroupReq[GroupType], fDefencePositions.TroopFormations[GroupType].NumUnits)
|
||||
else
|
||||
Inc(GroupReq[GroupType], Max(fDefencePositions.TroopFormations[GroupType].NumUnits - CurrentGroup.Count, 0));
|
||||
|
||||
//If we don't need anyone - Exit
|
||||
I := 0;
|
||||
for GT := Low(GroupReq) to High(GroupReq) do
|
||||
Inc(I, GroupReq[GT]);
|
||||
if I = 0 then Exit;
|
||||
|
||||
//Find barracks
|
||||
SetLength(Barracks, gHands[fOwner].Stats.GetHouseQty(htBarracks));
|
||||
I := 0;
|
||||
HB := TKMHouseBarracks(gHands[fOwner].FindHouse(htBarracks, I+1));
|
||||
while HB <> nil do
|
||||
begin
|
||||
Barracks[I] := HB;
|
||||
Inc(I);
|
||||
HB := TKMHouseBarracks(gHands[fOwner].FindHouse(htBarracks, I+1));
|
||||
end;
|
||||
|
||||
// Decrease group requirements on number of soldiers that are not walked out of barracks yet
|
||||
for warrior in fUnitsEquipOrdered.Values do
|
||||
if not warrior.IsDeadOrDying then
|
||||
// Group req could change while warrior was walking out of barracks, so we could get negative value here
|
||||
GroupReq[UNIT_TO_GROUP_TYPE[warrior.UnitType]] := Max(0, GroupReq[UNIT_TO_GROUP_TYPE[warrior.UnitType]] - 1);
|
||||
|
||||
//Train troops where possible in each barracks
|
||||
for I := 0 to High(Barracks) do
|
||||
begin
|
||||
HB := Barracks[I];
|
||||
|
||||
//Chose a random group type that we are going to attempt to train (so we don't always train certain group types first)
|
||||
K := 0;
|
||||
repeat
|
||||
GT := TKMGroupType(GROUP_TYPE_MIN_OFF + KaMRandom(4{$IFDEF DBG_RNG_SPY}, 'TKMGeneral.CheckArmyCount'{$ENDIF})); //Pick random from overall count
|
||||
Inc(K);
|
||||
until (GroupReq[GT] > 0) or (K > 9); //Limit number of attempts to guarantee it doesn't loop forever
|
||||
|
||||
if GroupReq[GT] = 0 then
|
||||
Break; // Don't train
|
||||
|
||||
for K := Low(AI_TROOP_TRAIN_ORDER[GT]) to High(AI_TROOP_TRAIN_ORDER[GT]) do
|
||||
begin
|
||||
UT := AI_TROOP_TRAIN_ORDER[GT, K];
|
||||
|
||||
if (UT <> utNone) then
|
||||
while ((CanEquipIron and (UT in WARRIORS_IRON)) or (CanEquipLeather and not (UT in WARRIORS_IRON)))
|
||||
and (GroupReq[GT] > 0)
|
||||
and ((fSetup.MaxSoldiers = -1) or (gHands[fOwner].Stats.GetArmyCount < fSetup.MaxSoldiers)) do
|
||||
begin
|
||||
warrior := TKMUnitWarrior(HB.EquipWarrior(UT));
|
||||
if warrior = nil then //We cant make unit of this type
|
||||
Break; //Continue with next UnitType
|
||||
|
||||
//Save unit we just equipped in the list of units, that has to be equipped
|
||||
//Problem is that we could make several orders before all equipped units will exit the barracks
|
||||
//and register in the defence position groups
|
||||
//So we will order more units in that case, who will eventually exit the barracks and chill around,
|
||||
//because all defence groups are filled already
|
||||
fUnitsEquipOrdered.Add(warrior.UID, TKMUnitWarrior(warrior.GetPointer));
|
||||
|
||||
Dec(GroupReq[GT]);
|
||||
//Only reset it when we actually trained something (in IronThenLeather mode we don't count them separately)
|
||||
if (UT in WARRIORS_IRON) or (fSetup.ArmyType = atIronThenLeather) then
|
||||
fLastEquippedTimeIron := gGameParams.Tick;
|
||||
if not (UT in WARRIORS_IRON) or (fSetup.ArmyType = atIronThenLeather) then
|
||||
fLastEquippedTimeLeather := gGameParams.Tick;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
//Check army food level and positioning
|
||||
procedure TKMGeneral.CheckArmy;
|
||||
var
|
||||
I: Integer;
|
||||
GroupType: TKMGroupType;
|
||||
Group: TKMUnitGroup;
|
||||
NeedsLinkingTo: array [GROUP_TYPE_MIN..GROUP_TYPE_MAX] of TKMUnitGroup;
|
||||
begin
|
||||
for GroupType := GROUP_TYPE_MIN to GROUP_TYPE_MAX do
|
||||
NeedsLinkingTo[GroupType] := nil;
|
||||
|
||||
//Check: Hunger, (feed) formation, (units per row) position (from defence positions)
|
||||
for I := 0 to gHands[fOwner].UnitGroups.Count - 1 do
|
||||
begin
|
||||
Group := gHands[fOwner].UnitGroups[I];
|
||||
|
||||
if not Group.IsDead
|
||||
and not Group.InFight(True)
|
||||
and (Group.Condition < UNIT_MIN_CONDITION) then
|
||||
//Check hunger and order food
|
||||
//Cheat for autobuild AI: Only feed hungry group members (food consumption lower and more predictable)
|
||||
//Do not clear offenders here, since we could follow attacker
|
||||
Group.OrderFood(False, fSetup.AutoBuild);
|
||||
|
||||
if not Group.IsDead
|
||||
and Group.IsIdleToAI([wtokFlagPoint, wtokHaltOrder])
|
||||
and not gGame.IsPeaceTime then //Do not process attack or defence during peacetime
|
||||
begin
|
||||
//We already have a position, finished with this group
|
||||
if fDefencePositions.FindPositionOf(Group) <> nil then Continue;
|
||||
|
||||
//Look for a new position to defend
|
||||
//In this case we choose the closest group, then move to a higher priority one later (see above)
|
||||
//This means at the start of the mission troops will take the position they are placed at rather than swapping around
|
||||
//With auto defence we reset defence positions regularly, so take closest rather than reshuffling all the time (newly equipped warriors still take highest priority)
|
||||
if fDefencePositions.FindPlaceForGroup(Group, AI_FILL_CLOSEST_IDLE or fSetup.AutoDefend) then Continue;
|
||||
|
||||
//Just chill and link with other idle groups
|
||||
if AI_LINK_IDLE then
|
||||
begin
|
||||
GroupType := Group.GroupType; //Remember it because Group might get emptied
|
||||
if NeedsLinkingTo[GroupType] = nil then
|
||||
begin
|
||||
//If this group doesn't have enough members
|
||||
if (Group.Count < fDefencePositions.TroopFormations[GroupType].NumUnits) then
|
||||
NeedsLinkingTo[GroupType] := Group //Flag us as needing to be added to
|
||||
end
|
||||
else
|
||||
begin
|
||||
//Look for group that needs additional members
|
||||
fDefencePositions.RestockPositionWith(NeedsLinkingTo[GroupType], Group);
|
||||
if NeedsLinkingTo[GroupType].Count >= fDefencePositions.TroopFormations[GroupType].NumUnits then
|
||||
NeedsLinkingTo[GroupType] := nil; //Group is now full
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGeneral.CheckAttacks;
|
||||
var
|
||||
MenAvailable: TKMGroupTypeArray; //Total number of warriors available to attack the enemy
|
||||
GroupsAvailable: TKMGroupTypeArray;
|
||||
MaxGroupsAvailable: Integer;
|
||||
AttackGroups: array [GROUP_TYPE_MIN..GROUP_TYPE_MAX] of array of TKMUnitGroup;
|
||||
|
||||
procedure AddAvailable(aGroup: TKMUnitGroup);
|
||||
var
|
||||
GT: TKMGroupType;
|
||||
begin
|
||||
GT := UNIT_TO_GROUP_TYPE[aGroup.UnitType];
|
||||
if Length(AttackGroups[GT]) <= GroupsAvailable[GT] then
|
||||
SetLength(AttackGroups[GT], GroupsAvailable[GT] + 10);
|
||||
AttackGroups[GT, GroupsAvailable[GT]] := aGroup;
|
||||
Inc(GroupsAvailable[GT]);
|
||||
MaxGroupsAvailable := Max(MaxGroupsAvailable, GroupsAvailable[GT]);
|
||||
Inc(MenAvailable[GT], aGroup.Count);
|
||||
end;
|
||||
|
||||
var
|
||||
I, K, J: Integer;
|
||||
G: TKMGroupType;
|
||||
Group: TKMUnitGroup;
|
||||
DP: TAIDefencePosition;
|
||||
UnitsSent: Integer;
|
||||
AttackLaunched: Boolean;
|
||||
Looped: Integer;
|
||||
begin
|
||||
//Do not process attack or defence during peacetime
|
||||
if gGame.IsPeaceTime then Exit;
|
||||
|
||||
Looped := 0;
|
||||
repeat
|
||||
AttackLaunched := False;
|
||||
MaxGroupsAvailable := 0;
|
||||
for G := GROUP_TYPE_MIN to GROUP_TYPE_MAX do
|
||||
begin
|
||||
GroupsAvailable[G] := 0;
|
||||
MenAvailable[G] := 0;
|
||||
end;
|
||||
|
||||
//Order of units is prioritized:
|
||||
//1. Take all idling Groups that are not linked to any Defence positions
|
||||
for I := 0 to gHands[fOwner].UnitGroups.Count - 1 do
|
||||
begin
|
||||
Group := gHands[fOwner].UnitGroups[I];
|
||||
if not Group.IsDead
|
||||
and Group.IsIdleToAI([wtokFlagPoint, wtokHaltOrder]) then
|
||||
begin
|
||||
DP := fDefencePositions.FindPositionOf(Group);
|
||||
if DP = nil then
|
||||
AddAvailable(Group);
|
||||
end;
|
||||
end;
|
||||
//2. Take back line defence positions, lowest priority first
|
||||
for I := fDefencePositions.Count-1 downto 0 do
|
||||
if (fDefencePositions[I].DefenceType = dtBackLine)
|
||||
and (fDefencePositions[I].CurrentGroup <> nil)
|
||||
and not fDefencePositions[I].CurrentGroup.IsDead
|
||||
and fDefencePositions[I].CurrentGroup.IsIdleToAI([wtokFlagPoint, wtokHaltOrder, wtokAIGotoDefencePos]) then
|
||||
AddAvailable(fDefencePositions[I].CurrentGroup);
|
||||
|
||||
//Now process AI attacks (we have compiled a list of warriors available to attack)
|
||||
for I := 0 to Attacks.Count - 1 do
|
||||
if Attacks.CanOccur(I, MenAvailable, GroupsAvailable, gGameParams.Tick) then //Check conditions are right
|
||||
begin
|
||||
AttackLaunched := True;
|
||||
//Order groups to attack
|
||||
UnitsSent := 0;
|
||||
if Attacks[I].RandomGroups then
|
||||
begin
|
||||
//Repeatedly send one of each group type until we have sent the required amount (mixed army)
|
||||
for K := 0 to MaxGroupsAvailable - 1 do
|
||||
for G := GROUP_TYPE_MIN to GROUP_TYPE_MAX do
|
||||
if (UnitsSent < Attacks[I].TotalMen) and (K < GroupsAvailable[G]) then
|
||||
begin
|
||||
OrderAttack(AttackGroups[G, K], Attacks[I].Target, Attacks[I].CustomPosition);
|
||||
Inc(UnitsSent, AttackGroups[G, K].Count);
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
//First send the number of each group as requested by the attack
|
||||
for G := GROUP_TYPE_MIN to GROUP_TYPE_MAX do
|
||||
for K := 0 to Attacks[I].GroupAmounts[G] - 1 do
|
||||
begin
|
||||
OrderAttack(AttackGroups[G, K], Attacks[I].Target, Attacks[I].CustomPosition);
|
||||
Inc(UnitsSent, AttackGroups[G, K].Count);
|
||||
end;
|
||||
|
||||
//If we still haven't sent enough men, send more groups out of the types allowed until we have
|
||||
if UnitsSent < Attacks[I].TotalMen then
|
||||
for K := 0 to MaxGroupsAvailable - 1 do
|
||||
for G := GROUP_TYPE_MIN to GROUP_TYPE_MAX do
|
||||
begin
|
||||
//Start index after the ones we've already sent above (ones required by attack)
|
||||
J := K + Attacks[I].GroupAmounts[G];
|
||||
if (Attacks[I].GroupAmounts[G] > 0) and (UnitsSent < Attacks[I].TotalMen)
|
||||
and (J < GroupsAvailable[G]) then
|
||||
begin
|
||||
OrderAttack(AttackGroups[G, J], Attacks[I].Target, Attacks[I].CustomPosition);
|
||||
Inc(UnitsSent, AttackGroups[G, J].Count);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
Attacks.HasOccured(I); //We can't set the flag to property record directly
|
||||
Break; //Only order 1 attack per update, since all the numbers of groups available need recalculating
|
||||
end;
|
||||
Inc(Looped);
|
||||
//if there's no target available we could loop forever ordering the same attack, so limit it
|
||||
until (not AttackLaunched) or (Looped > 10);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGeneral.CheckAutoAttack;
|
||||
var
|
||||
SimpleAttack: TKMAIAttack;
|
||||
H: TKMHouse;
|
||||
begin
|
||||
//Simple test for now
|
||||
FillChar(SimpleAttack, SizeOf(SimpleAttack), #0);
|
||||
|
||||
SimpleAttack.AttackType := aatRepeating;
|
||||
SimpleAttack.Target := attClosestBuildingFromStartPos;
|
||||
SimpleAttack.TotalMen := fDefencePositions.AverageUnitsPerGroup *
|
||||
fDefencePositions.GetBacklineCount div 2;
|
||||
SimpleAttack.RandomGroups := True;
|
||||
|
||||
Attacks.Clear;
|
||||
Attacks.AddAttack(SimpleAttack);
|
||||
|
||||
//If start position isn't set, set it to first storehouse (used for targeting attacks)
|
||||
if (fSetup.StartPosition.X <= 1) and (fSetup.StartPosition.Y <= 1) then
|
||||
begin
|
||||
H := gHands[fOwner].Houses.FindHouse(htStore, 0, 0, 1);
|
||||
if H <> nil then
|
||||
fSetup.StartPosition := H.Entrance;
|
||||
end;
|
||||
|
||||
//See how many soldiers we need to launch an attack
|
||||
|
||||
//Check if we have enough troops we can take into attack (Backline formations)
|
||||
|
||||
//Check if we can train more soldiers (ignoring EquipRate?)
|
||||
|
||||
//Make decision about attack
|
||||
|
||||
//Choose place to attack
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGeneral.CheckAutoDefend;
|
||||
|
||||
//function EnsureWalkable(var Loc: TKMPoint): Boolean;
|
||||
//var
|
||||
// IX, IY, BestDistSqr: Integer;
|
||||
// Best: TKMPoint;
|
||||
//begin
|
||||
// if gTerrain.CheckPassability(Loc, tpWalk) then
|
||||
// begin
|
||||
// Result := True;
|
||||
// Exit;
|
||||
// end;
|
||||
// Result := False;
|
||||
// BestDistSqr := High(Integer);
|
||||
// for IY := Max(1, Loc.Y-2) to Min(gTerrain.MapY, Loc.Y+2) do
|
||||
// for IX := Max(1, Loc.X-2) to Min(gTerrain.MapX, Loc.X+2) do
|
||||
// if gTerrain.CheckPassability(KMPoint(IX, IY), tpWalk)
|
||||
// and (KMLengthSqr(Loc, KMPoint(IX, IY)) < BestDistSqr) then
|
||||
// begin
|
||||
// BestDistSqr := KMLengthSqr(Loc, KMPoint(IX, IY));
|
||||
// Best := KMPoint(IX, IY);
|
||||
// Result := True;
|
||||
// end;
|
||||
// if Result then
|
||||
// Loc := Best;
|
||||
//end;
|
||||
|
||||
const
|
||||
MIN_DEF_POS = 6;
|
||||
var
|
||||
DefPosArr: TKMDefencePosArr;
|
||||
I: Integer;
|
||||
BestOwner: TKMHandID;
|
||||
Loc: TKMPoint;
|
||||
GT: TKMGroupType;
|
||||
DPT: TKMAIDefencePosType;
|
||||
//Outline1, Outline2: TKMWeightSegments;
|
||||
//Locs: TKMPointDirTagList;
|
||||
//LocI: TKMPoint;
|
||||
//FaceDir: TKMDirection;
|
||||
//SegLength, Ratio: Single;
|
||||
//DefCount: Byte;
|
||||
//Weight: Cardinal;
|
||||
//FirstLineCount,BacklineCount: Integer;
|
||||
begin
|
||||
//Get defence Outline with weights representing how important each segment is
|
||||
if not gAIFields.NavMesh.Defences.FindDefensivePolygons(fOwner, DefPosArr) then
|
||||
Exit;
|
||||
|
||||
fDefencePositions.Clear;
|
||||
for I := Low(DefPosArr) to High(DefPosArr) do
|
||||
begin
|
||||
BestOwner := gAIFields.Influences.GetBestOwner(DefPosArr[I].Polygon);
|
||||
if (BestOwner = fOwner) OR (BestOwner = HAND_NONE) OR (fDefencePositions.Count + Length(DefPosArr) <= MIN_DEF_POS) then
|
||||
begin
|
||||
if (DefPosArr[I].Line = 0) then
|
||||
DPT := dtFrontLine
|
||||
else
|
||||
DPT := dtBackLine;
|
||||
Loc := DefPosArr[I].DirPoint.Loc;
|
||||
case (Loc.X*2 + Loc.Y*2) mod 3 of
|
||||
0: GT := gtAntiHorse;
|
||||
1: GT := gtRanged;
|
||||
else GT := gtMelee;
|
||||
end;
|
||||
fDefencePositions.Add(DefPosArr[I].DirPoint, GT, 25, DPT);
|
||||
end;
|
||||
end;
|
||||
|
||||
//BacklineCount := 0;
|
||||
//FirstLineCount := 0;
|
||||
|
||||
//Locs := TKMPointDirTagList.Create;
|
||||
//try
|
||||
//Make list of defence positions
|
||||
|
||||
//for I := 0 to High(Outline2) do
|
||||
//begin
|
||||
// FaceDir := KMGetDirection(KMPointF(Outline2[I].A), KMPerpendecular(Outline2[I].A, Outline2[I].B));
|
||||
//
|
||||
// //Longer segments will get several DefencePositions
|
||||
// SegLength := KMLength(Outline2[I].A, Outline2[I].B);
|
||||
// DefCount := Max(Trunc(SegLength / 5), 1); //At least 1, otherwise we might leave a bridge undefended
|
||||
//
|
||||
// for K := 0 to DefCount - 1 do
|
||||
// begin
|
||||
// Ratio := (K + 1) / (DefCount + 1);
|
||||
// Loc := KMPointRound(KMLerp(Outline2[I].A, Outline2[I].B, Ratio));
|
||||
// Weight := Round(Outline2[I].Weight * 100);
|
||||
// //Make sure each segment gets 1 defence position before filling others (in the middle of the segment line)
|
||||
// if K = ((DefCount - 1) div 2) then
|
||||
// Weight := Weight + 10000;
|
||||
//
|
||||
// Locs.Add(KMPointDir(Loc, FaceDir), Weight);
|
||||
// end;
|
||||
//end;
|
||||
|
||||
//Sort according to positions weight
|
||||
//Locs.SortByTag;
|
||||
|
||||
//Add defence positions
|
||||
//for I := Locs.Count - 1 downto 0 do
|
||||
//begin
|
||||
// LocI := KMGetPointInDir(Locs.Items[I].Loc, Locs.Items[I].Dir, 1);
|
||||
// Loc := gTerrain.EnsureTileInMapCoords(LocI.X, LocI.Y, 3);
|
||||
// if not EnsureWalkable(Loc) then
|
||||
// Continue;
|
||||
//
|
||||
// //Mix group types deterministicly based on Loc, so they don't change for a given position
|
||||
// case (Loc.X*2 + Loc.Y*2) mod 3 of
|
||||
// 0: GT := gtAntiHorse;
|
||||
// else GT := gtMelee;
|
||||
// end;
|
||||
// //Low weight positions are set to backline (when one segment has more than one position)
|
||||
// if Locs.Tag[I] < 10000 then
|
||||
// DPT := adtBackLine
|
||||
// else
|
||||
// DPT := adtFrontLine;
|
||||
//
|
||||
// fDefencePositions.Add(KMPointDir(Loc, Locs[I].Dir), GT, 25, DPT);
|
||||
// if DPT = adtBackLine then Inc(BacklineCount);
|
||||
//
|
||||
// LocI := KMGetPointInDir(Locs[I].Loc, KMAddDirection(Locs[I].Dir, 4), 4);
|
||||
// Loc := gTerrain.EnsureTileInMapCoords(LocI.X, LocI.Y, 3);
|
||||
// if not EnsureWalkable(Loc) then
|
||||
// Continue;
|
||||
//
|
||||
// fDefencePositions.Add(KMPointDir(Loc, Locs[I].Dir), gtRanged, 25, DPT);
|
||||
// if DPT = adtBackLine then Inc(BacklineCount);
|
||||
//end;
|
||||
|
||||
//Add extra backline defence positions after adding all the front line ones so they are lower priority
|
||||
//for I := Locs.Count - 1 downto 0 do
|
||||
//if BacklineCount < 12 then
|
||||
//begin
|
||||
// //Try to add backline defence positions behind front line, if there's space
|
||||
// Loc := KMGetPointInDir(Locs[I].Loc, KMAddDirection(Locs[I].Dir, 4), 7);
|
||||
// if gTerrain.TileInMapCoords(Loc.X, Loc.Y, 3) then
|
||||
// begin
|
||||
// if not EnsureWalkable(Loc) then
|
||||
// Continue;
|
||||
//
|
||||
// //Mix group types deterministicly based on Loc, so they don't change for a given position
|
||||
// case (Loc.X*2 + Loc.Y*2) mod 3 of
|
||||
// 0: GT := gtAntiHorse;
|
||||
// 1: GT := gtRanged;
|
||||
// else GT := gtMelee;
|
||||
// end;
|
||||
// fDefencePositions.Add(KMPointDir(Loc, Locs[I].Dir), GT, 35, adtBackLine);
|
||||
// Inc(BacklineCount);
|
||||
// end;
|
||||
//end;
|
||||
//finally
|
||||
// Locs.Free;
|
||||
//end;
|
||||
|
||||
//Compare existing defence positions with the sample
|
||||
//Get the ratio between sample and existing troops
|
||||
//Check all segments to have proportional troops count
|
||||
//Add or remove defence positions
|
||||
end;
|
||||
|
||||
|
||||
//See if we can attack our enemies
|
||||
procedure TKMGeneral.OrderAttack(aGroup: TKMUnitGroup; aTarget: TKMAIAttackTarget; const aCustomPos: TKMPoint);
|
||||
const
|
||||
TARGET_HOUSES: TKMHouseTypeSet = HOUSES_VALID;
|
||||
var
|
||||
TargetHouse: TKMHouse;
|
||||
TargetUnit: TKMUnit;
|
||||
begin
|
||||
TargetHouse := nil;
|
||||
TargetUnit := nil;
|
||||
|
||||
//Find target
|
||||
case aTarget of
|
||||
attClosestUnit: TargetUnit := gHands.GetClosestUnit(aGroup.Position, fOwner, atEnemy);
|
||||
attClosestBuildingFromArmy: TargetHouse := gHands.GetClosestHouse(aGroup.Position, fOwner, atEnemy, TARGET_HOUSES, False);
|
||||
attClosestBuildingFromStartPos: TargetHouse := gHands.GetClosestHouse(fSetup.StartPosition, fOwner, atEnemy, TARGET_HOUSES, False);
|
||||
attCustomPosition: begin
|
||||
TargetHouse := gHands.HousesHitTest(aCustomPos.X, aCustomPos.Y);
|
||||
if (TargetHouse <> nil) and
|
||||
(gHands.CheckAlliance(fOwner, TargetHouse.Owner) = atAlly) then
|
||||
TargetHouse := nil;
|
||||
|
||||
TargetUnit := gTerrain.UnitsHitTest(aCustomPos.X, aCustomPos.Y);
|
||||
if (TargetUnit <> nil)
|
||||
and ((gHands.CheckAlliance(fOwner, TargetUnit.Owner) = atAlly)
|
||||
or TargetUnit.IsDeadOrDying) then
|
||||
TargetUnit := nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
//Choose best option
|
||||
if TargetHouse <> nil then
|
||||
aGroup.OrderAttackHouse(TargetHouse, True)
|
||||
else if TargetUnit <> nil then
|
||||
aGroup.OrderAttackUnit(TargetUnit, True)
|
||||
else if aTarget = attCustomPosition then
|
||||
aGroup.OrderWalk(aCustomPos, True, wtokAIAttackCustomPos);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGeneral.RetaliateAgainstThreat(aAttacker: TKMUnit);
|
||||
var
|
||||
I: Integer;
|
||||
Group: TKMUnitGroup;
|
||||
begin
|
||||
if gHands[fOwner].IsHuman then Exit;
|
||||
|
||||
//Attacker may be already dying (e.g. killed by script)
|
||||
//We could retaliate against his whole group however
|
||||
if (aAttacker = nil) or aAttacker.IsDeadOrDying or (aAttacker is TKMUnitRecruit) then Exit;
|
||||
|
||||
//todo -cComplicated: Right now "idle" troops (without an assigned defence position) will do nothing (no attacking, defending, etc.)
|
||||
//Any defence position that is within their defence radius of this threat will retaliate against it
|
||||
for I := 0 to fDefencePositions.Count - 1 do
|
||||
begin
|
||||
Group := fDefencePositions[I].CurrentGroup;
|
||||
if (Group <> nil)
|
||||
and not Group.IsDead
|
||||
and Group.IsIdleToAI([wtokFlagPoint, wtokHaltOrder, wtokAIGotoDefencePos])
|
||||
//Units walking to their defence position can retaliate (but not if pursuing an enemy)
|
||||
//@Lewin: Is it right that Group defends against attackers within the Rad
|
||||
//rather than defending property within the Rad?
|
||||
//Think of archer, he attacks property in AI defense radius, but stands utself outside of the radius
|
||||
//should AI retaliate against him or not?
|
||||
//@Krom: Yes it's right the way it is now. It should be the attacker not the victim.
|
||||
//Otherwise the AI sends much more groups when you shoot them with 1 bowmen in the campaigns.
|
||||
//Right now it seems to be working almost the same as in the original game.
|
||||
and (KMLengthDiag(Group.Position, aAttacker.Position) <= fDefencePositions[I].Radius) then
|
||||
Group.OrderAttackUnit(aAttacker, True);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGeneral.RemoveEquipOrderedWarrior(aWarrior: TKMUnitWarrior);
|
||||
begin
|
||||
if fUnitsEquipOrdered.ContainsKey(aWarrior.UID) then
|
||||
begin
|
||||
fUnitsEquipOrdered[aWarrior.UID].ReleasePointer;
|
||||
fUnitsEquipOrdered.Remove(aWarrior.UID);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
//Trained warrior reports for duty
|
||||
procedure TKMGeneral.WarriorEquipped(aWarrior: TKMUnitWarrior);
|
||||
begin
|
||||
RemoveEquipOrderedWarrior(aWarrior);
|
||||
fDefencePositions.FindPlaceForGroup(TKMUnitGroup(aWarrior.Group), AI_FILL_CLOSEST_EQUIPPED);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGeneral.WarriorDied(aWarrior: TKMUnitWarrior);
|
||||
begin
|
||||
RemoveEquipOrderedWarrior(aWarrior);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGeneral.UpdateState(aTick: Cardinal);
|
||||
begin
|
||||
{$IFDEF DBG_PERFLOG}
|
||||
gPerfLogs.SectionEnter(psAIArmyCls);
|
||||
{$ENDIF}
|
||||
try
|
||||
//Update defence positions locations
|
||||
if fSetup.AutoDefend then
|
||||
//Checking mod result against MAX_HANDS causes first update to happen ASAP
|
||||
if (aTick + Byte(fOwner)) mod (MAX_HANDS * 50) = MAX_HANDS then
|
||||
CheckAutoDefend;
|
||||
|
||||
//See if we can launch an attack
|
||||
if fSetup.AutoAttack then
|
||||
if (aTick + Byte(fOwner)) mod (MAX_HANDS * 50) = 1 then
|
||||
CheckAutoAttack;
|
||||
|
||||
if (aTick + Byte(fOwner)) mod MAX_HANDS = 0 then
|
||||
begin
|
||||
fDefencePositions.UpdateState;
|
||||
CheckArmy; //Feed army, position defence, arrange/organise groups
|
||||
CheckAttacks;
|
||||
CheckArmyCount; //Train new soldiers if needed
|
||||
|
||||
//CheckEnemyPresence; //Check enemy threat in close range and issue defensive attacks (or flee?)
|
||||
//CheckAndIssueAttack; //Attack enemy
|
||||
//Anything Else?
|
||||
end;
|
||||
finally
|
||||
{$IFDEF DBG_PERFLOG}
|
||||
gPerfLogs.SectionLeave(psAIArmyCls);
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
+252
@@ -0,0 +1,252 @@
|
||||
unit KM_AIGoals;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
KM_CommonClasses, KM_Defaults, KM_MapTypes;
|
||||
|
||||
|
||||
type
|
||||
TKMGoal = packed record
|
||||
GoalType: TKMGoalType; //Victory, survive, neither
|
||||
GoalCondition: TKMGoalCondition; //Buildings, troops, time passing
|
||||
GoalStatus: TKMGoalStatus; //Must this condition be True or False (same as alive or dead) for victory/surival to occur?
|
||||
GoalTime: Cardinal; //Only used with gaTime. Amount of time (in game ticks) that must pass before this goal is complete
|
||||
MessageToShow: Integer; //Message to be shown when the goal is completed
|
||||
MessageHasShown: Boolean; //Whether we have shown this message yet
|
||||
HandIndex: TKMHandID; //Player whose buildings or troops must be destroyed
|
||||
Disabled: Boolean;
|
||||
end;
|
||||
//Because the goal system is hard to understand, here are some examples:
|
||||
{Destroy troops of player 2 in order to win
|
||||
Script command: !ADD_GOAL 4 1 0 2
|
||||
GoalType=gltVictory
|
||||
GoalCondition=gcTroops
|
||||
GoalStatus=gsFalse //Troops must be dead, non-existant. i.e. the condition that player 2 has troops must be FALSE.
|
||||
Player=play_2
|
||||
}
|
||||
|
||||
{Save (protect) troops of player 1 or else you will lose the game
|
||||
Script command: !ADD_LOST_GOAL 4 0 0 1
|
||||
GoalType=gltSurvive
|
||||
GoalCondition=gcTroops
|
||||
GoalStatus=gsTrue //Troops must be alive. i.e. the condition that player 1 has troops must be TRUE otherwise you lose.
|
||||
Player=play_1
|
||||
}
|
||||
|
||||
{Display message 500 after 10 minutes (no goal, just message)
|
||||
Script command: !ADD_GOAL 2 0 500 600
|
||||
GoalType=gltNone
|
||||
GoalCondition=gcTime
|
||||
GoalStatus=gsTrue //Time must have passed
|
||||
GoalTime=600
|
||||
MessageToShow=500
|
||||
}
|
||||
|
||||
{Display message 510 upon buildings of player 4 being destroyed
|
||||
Script command: !ADD_GOAL 3 1 510 4 (in this case the script command would also require the buildings to be destroyed for a victory condition, as mentioned bellow)
|
||||
GoalType=gltNone //If this was set to victory or survive not only would the message be displayed, but it would also be a condition for winning/losing
|
||||
GoalCondition=gcBuildings
|
||||
GoalStatus=gsFalse //Buildings must be destroyed
|
||||
MessageToShow=500
|
||||
}
|
||||
|
||||
|
||||
type
|
||||
TKMGoals = class
|
||||
private
|
||||
fCount: Integer;
|
||||
fGoals: array of TKMGoal;
|
||||
function GetGoal(aIndex: Integer): TKMGoal;
|
||||
procedure SetGoal(aIndex: Integer; const Value: TKMGoal);
|
||||
public
|
||||
procedure Clear;
|
||||
property Count: Integer read fCount;
|
||||
property Item[aIndex: Integer]: TKMGoal read GetGoal write SetGoal; default;
|
||||
procedure AddGoal(aType: TKMGoalType; aCondition: TKMGoalCondition; aStatus: TKMGoalStatus; aTime: Cardinal;
|
||||
aMessageToShow: Integer; aHandIndex: TKMHandID); overload; // Deprecated
|
||||
procedure AddGoal(aType: TKMGoalType; aCondition: TKMGoalCondition; aHandIndex: TKMHandID); overload;
|
||||
procedure AddGoal(const aGoal: TKMGoal); overload;
|
||||
procedure Delete(aIndex: Integer);
|
||||
procedure RemoveReference(aHandIndex: TKMHandID);
|
||||
procedure UpdateGoalsForHand(aHandIndex: TKMHandID; aEnable: Boolean);
|
||||
procedure SetMessageHasShown(aIndex: Integer);
|
||||
procedure AddDefaultGoals(aBuildings: Boolean; aOurPlayerIndex: TKMHandID; const aEnemyIndexes: array of TKMHandID);
|
||||
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure Load(LoadStream: TKMemoryStream);
|
||||
|
||||
procedure ExportMessages(const aPath: UnicodeString);
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Classes, SysUtils, Math;
|
||||
|
||||
|
||||
{ TKMGoals }
|
||||
function TKMGoals.GetGoal(aIndex: Integer): TKMGoal;
|
||||
begin
|
||||
Result := fGoals[aIndex];
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGoals.SetGoal(aIndex: Integer; const Value: TKMGoal);
|
||||
begin
|
||||
fGoals[aIndex] := Value;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGoals.AddGoal(aType: TKMGoalType; aCondition: TKMGoalCondition; aHandIndex: TKMHandID);
|
||||
var
|
||||
status: TKMGoalStatus;
|
||||
begin
|
||||
if aType = gltVictory then
|
||||
status := gsFalse
|
||||
else
|
||||
status := gsTrue;
|
||||
|
||||
AddGoal(aType, aCondition, status, 0, 0, aHandIndex);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGoals.AddGoal(aType: TKMGoalType; aCondition: TKMGoalCondition; aStatus: TKMGoalStatus; aTime: Cardinal;
|
||||
aMessageToShow: Integer; aHandIndex: TKMHandID);
|
||||
begin
|
||||
SetLength(fGoals, fCount + 1);
|
||||
fGoals[fCount].GoalType := aType;
|
||||
fGoals[fCount].GoalCondition := aCondition;
|
||||
fGoals[fCount].GoalStatus := aStatus;
|
||||
fGoals[fCount].GoalTime := aTime;
|
||||
fGoals[fCount].MessageToShow := aMessageToShow;
|
||||
fGoals[fCount].HandIndex := aHandIndex;
|
||||
fGoals[fCount].MessageHasShown := False;
|
||||
fGoals[fCount].Disabled := False;
|
||||
Inc(fCount);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGoals.AddGoal(const aGoal: TKMGoal);
|
||||
begin
|
||||
if fCount >= Length(fGoals) then
|
||||
SetLength(fGoals, fCount + 16);
|
||||
|
||||
fGoals[fCount] := aGoal;
|
||||
Inc(fCount);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGoals.Clear;
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
|
||||
fCount := 0;
|
||||
SetLength(fGoals, 0);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGoals.Delete(aIndex: Integer);
|
||||
begin
|
||||
Assert(InRange(aIndex, 0, Count - 1));
|
||||
|
||||
if (aIndex <> Count - 1) then
|
||||
Move(fGoals[aIndex + 1], fGoals[aIndex], (fCount - 1 - aIndex) * SizeOf(TKMGoal));
|
||||
|
||||
Dec(fCount);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGoals.UpdateGoalsForHand(aHandIndex: TKMHandID; aEnable: Boolean);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
for I := 0 to fCount - 1 do
|
||||
if fGoals[I].HandIndex = aHandIndex then
|
||||
fGoals[I].Disabled := not aEnable;
|
||||
end;
|
||||
|
||||
|
||||
// We don't want anyones goal to use deleted player
|
||||
// Used when we delete certain player from MapEd
|
||||
procedure TKMGoals.RemoveReference(aHandIndex: TKMHandID);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
for I := fCount - 1 downto 0 do
|
||||
if fGoals[I].HandIndex > aHandIndex then
|
||||
fGoals[I].HandIndex := pred(fGoals[I].HandIndex)
|
||||
else if fGoals[I].HandIndex = aHandIndex then
|
||||
Delete(I);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGoals.SetMessageHasShown(aIndex: Integer);
|
||||
begin
|
||||
fGoals[aIndex].MessageHasShown := True;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGoals.AddDefaultGoals(aBuildings: Boolean; aOurPlayerIndex: TKMHandID; const aEnemyIndexes: array of TKMHandID);
|
||||
var
|
||||
I: Integer;
|
||||
gc: TKMGoalCondition;
|
||||
begin
|
||||
if aBuildings then
|
||||
gc := gcBuildings
|
||||
else
|
||||
gc := gcTroops;
|
||||
|
||||
// Default Defeat condition is to lose army/town
|
||||
AddGoal(gltSurvive, gc, aOurPlayerIndex);
|
||||
|
||||
// Default Victory conditions is to kill armies / destroy towns of all other players
|
||||
for I := 0 to Length(aEnemyIndexes) - 1 do
|
||||
AddGoal(gltVictory, gc, aEnemyIndexes[I]);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGoals.Save(SaveStream: TKMemoryStream);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
SaveStream.PlaceMarker('Goals');
|
||||
SaveStream.Write(fCount);
|
||||
for I := 0 to fCount - 1 do
|
||||
SaveStream.Write(fGoals[I], SizeOf(fGoals[I]));
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMGoals.Load(LoadStream: TKMemoryStream);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
LoadStream.CheckMarker('Goals');
|
||||
LoadStream.Read(fCount);
|
||||
SetLength(fGoals, fCount);
|
||||
for I := 0 to fCount - 1 do
|
||||
LoadStream.Read(fGoals[I], SizeOf(fGoals[I]));
|
||||
end;
|
||||
|
||||
|
||||
//In-house method to convert KaM 'show_message' goals into EVT scripts
|
||||
procedure TKMGoals.ExportMessages(const aPath: UnicodeString);
|
||||
var
|
||||
I: Integer;
|
||||
SL: TStringList;
|
||||
begin
|
||||
SL := TStringList.Create;
|
||||
|
||||
for I := 0 to fCount - 1 do
|
||||
if Item[I].MessageToShow > 0 then
|
||||
SL.Add('TIME -1 ' +
|
||||
IntToStr(Item[I].GoalTime) +
|
||||
' SHOW_MESSAGE 0 ' +
|
||||
IntToStr(Item[I].MessageToShow)); //-529 for TSK, -549 for TPR
|
||||
|
||||
if SL.Count > 0 then
|
||||
SL.SaveToFile(aPath);
|
||||
SL.Free;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
+860
@@ -0,0 +1,860 @@
|
||||
unit KM_AIInfluences;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Math,
|
||||
KM_CommonClasses, KM_CommonTypes, KM_Defaults, KM_Points,
|
||||
KM_Units, KM_UnitGroup,
|
||||
KM_NavMesh, KM_NavMeshGenerator, KM_NavMeshInfluences,
|
||||
KM_NavMeshFloodFill;
|
||||
|
||||
|
||||
const
|
||||
// Avoid bulding values of specific actions (tile lock by specific action)
|
||||
AVOID_BUILDING_UNLOCK = 0;
|
||||
AVOID_BUILDING_HOUSE_OUTSIDE_LOCK = 10;
|
||||
AVOID_BUILDING_HOUSE_INSIDE_LOCK = 15;
|
||||
AVOID_BUILDING_HOUSE_ENTRANCE = 20;
|
||||
AVOID_BUILDING_COAL_TILE = 25;
|
||||
AVOID_BUILDING_NODE_LOCK_FIELD = 30;
|
||||
AVOID_BUILDING_NODE_LOCK_ROAD = 35;
|
||||
AVOID_BUILDING_MINE_TILE = 40;
|
||||
AVOID_BUILDING_FOREST_RANGE = 200; // Value: 255 <-> AVOID_BUILDING_FOREST_VARIANCE which may forest tiles have
|
||||
AVOID_BUILDING_FOREST_MINIMUM = 254 - AVOID_BUILDING_FOREST_RANGE; // Minimum value of forest reservation tiles
|
||||
|
||||
|
||||
type
|
||||
// Collection of influence maps
|
||||
TKMInfluences = class
|
||||
private
|
||||
fMapX, fMapY, fPolyCnt: Word; // Limits of arrays
|
||||
|
||||
fAlli2PL: TKMHandID2Array;
|
||||
|
||||
fAvoidBuilding: TKMByteArray; //Common map of areas where building is undesired (around Store, Mines, Woodcutters)
|
||||
fUpdateCityIdx, fUpdateArmyIdx: TKMHandID; // Update index
|
||||
fPresence: TKMWordArray; // Military presence
|
||||
fOwnership: TKMByteArray; // City mark the space around itself
|
||||
|
||||
fInfluenceFloodFill: TKMInfluenceFloodFill;
|
||||
fInfluenceSearch: TNavMeshInfluenceSearch;
|
||||
fNavMesh: TKMNavMesh;
|
||||
|
||||
{$IFDEF DEBUG_AIInfluences}
|
||||
fTimeAvrgOwnership, fTimeAvrgPresence: Int64;
|
||||
fTimePeakOwnership, fTimePeakPresence: Int64;
|
||||
{$ENDIF}
|
||||
|
||||
// Avoid building
|
||||
procedure InitAvoidBuilding();
|
||||
function GetAvoidBuilding(const aY,aX: Word): Byte;
|
||||
procedure SetAvoidBuilding(const aY,aX: Word; const aValue: Byte);
|
||||
// Army presence
|
||||
function GetPresence(const aAlliance, aIdx: Word; const aGT: TKMGroupType): Word;
|
||||
procedure SetPresence(const aAlliance, aIdx: Word; const aGT: TKMGroupType; const aPresence: Word); inline;
|
||||
procedure SetIncPresence(const aAlliance, aIdx: Word; const aGT: TKMGroupType; const aPresence: Word); inline;
|
||||
procedure UpdateMilitaryPresence(aAllianceIdx: Integer);
|
||||
procedure SetLengthOfPresence();
|
||||
// City influence
|
||||
function GetOwnership(const aPL: TKMHandID; const aIdx: Word): Byte; inline;
|
||||
procedure SetOwnership(const aPL: TKMHandID; const aIdx: Word; const aOwnership: Byte); inline;
|
||||
function GetOwnershipFromCoords(const aPL: TKMHandID; const aY, aX: Word): Byte; inline; // For property -> aY, aX are switched!
|
||||
procedure SetOwnershipFromCoords(const aPL: TKMHandID; const aY, aX: Word; const aOwnership: Byte); inline; // For property -> aY, aX are switched!
|
||||
function GetOwnershipFromPoint(const aPL: TKMHandID; const aPoint: TKMPoint): Byte; inline;
|
||||
procedure SetOwnershipFromPoint(const aPL: TKMHandID; const aPoint: TKMPoint; const aOwnership: Byte); inline;
|
||||
procedure UpdateOwnership(const aPL: TKMHandID);
|
||||
public
|
||||
constructor Create(aNavMesh: TKMNavMesh);
|
||||
destructor Destroy(); override;
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure Load(LoadStream: TKMemoryStream);
|
||||
|
||||
// Avoid building
|
||||
property AvoidBuilding[const aY,aX: Word]: Byte read GetAvoidBuilding write SetAvoidBuilding;
|
||||
// Army presence
|
||||
property Presence[const aAlliance, aIdx: Word; const aGT: TKMGroupType]: Word read GetPresence write SetPresence;
|
||||
property IncPresence[const aAlliance, aIdx: Word; const aGT: TKMGroupType]: Word write SetIncPresence;
|
||||
// City influence
|
||||
property Ownership[const aPL: TKMHandID; const aY,aX: Word]: Byte read GetOwnershipFromCoords write SetOwnershipFromCoords; // To secure compatibility with old AI
|
||||
property OwnPoint[const aPL: TKMHandID; const aPoint: TKMPoint]: Byte read GetOwnershipFromPoint write SetOwnershipFromPoint;
|
||||
property OwnPoly[const aPL: TKMHandID; const aIdx: Word]: Byte read GetOwnership write SetOwnership;
|
||||
// Common
|
||||
property InfluenceSearch: TNavMeshInfluenceSearch read fInfluenceSearch write fInfluenceSearch;
|
||||
|
||||
// Avoid building
|
||||
procedure AddAvoidBuilding(aX,aY: Word; aRad: Single);
|
||||
procedure RemAvoidBuilding(aArea: TKMRect);
|
||||
procedure MarkForest(aPoint: TKMPoint; aRad, aDecreaseCoef: Single; aOnlyUnmarkedArea: Boolean = False);
|
||||
// Army presence
|
||||
function GetAllianceIdx(const aPL: TKMHandID; var aIdx: Integer): Boolean;
|
||||
function GetArmyTraffic(const aAlliance, aIdx: Word): Word;
|
||||
// City influence
|
||||
function GetBestOwner(const aX,aY: Word): TKMHandID; overload;
|
||||
function GetBestOwner(const aIdx: Word): TKMHandID; overload;
|
||||
function GetBestAllianceOwner(const aPL: TKMHandID; const aPoint: TKMPoint; const aAllianceType: TKMAllianceType): TKMHandID;
|
||||
//function GetAllAllianceOwnership(const aPL: TKMHandIndex; const aX,aY: Word; const aAllianceType: TKMAllianceType): TKMHandIndexArray;
|
||||
function GetBestAllianceOwnership(const aPL: TKMHandID; const aX,aY: Word; const aAllianceType: TKMAllianceType): Byte; overload;
|
||||
function GetBestAllianceOwnership(const aPL: TKMHandID; const aIdx: Word; const aAllianceType: TKMAllianceType): Byte; overload;
|
||||
function GetOtherOwnerships(const aPL: TKMHandID; const aX, aY: Word): Word; overload;
|
||||
function GetOtherOwnerships(const aPL: TKMHandID; const aIdx: Word): Word; overload;
|
||||
function CanPlaceHouseByInfluence(const aPL: TKMHandID; const aX,aY: Word; const aIgnoreAllies: Boolean = False): Boolean; overload;
|
||||
function CanPlaceHouseByInfluence(const aPL: TKMHandID; const aIdx: Word; const aIgnoreAllies: Boolean = False): Boolean; overload;
|
||||
// Common
|
||||
procedure InitInfluences();
|
||||
|
||||
procedure AfterMissionInit();
|
||||
procedure UpdateState(aTick: Cardinal);
|
||||
procedure UpdateAlliances(const aAlli2PL: TKMHandID2Array);
|
||||
procedure Paint(const aRect: TKMRect);
|
||||
end;
|
||||
|
||||
const
|
||||
AVOID_TRAFFIC_IDX = 4; // Index of avoid traffic in the fOwnership array (0-3 are group types)
|
||||
|
||||
implementation
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
KM_RenderAux,
|
||||
{$IFDEF DEBUG_AIInfluences}
|
||||
KM_CommonUtils,
|
||||
{$ENDIF}
|
||||
KM_Terrain, KM_Houses, KM_HouseCollection,
|
||||
KM_Hand, KM_HandsCollection, KM_HandTypes,
|
||||
KM_ResTypes;
|
||||
|
||||
const
|
||||
PRESENCE_X = (GROUP_TYPES_CNT + 1); // number of group types (4) and 1 for traffic
|
||||
|
||||
|
||||
{ TKMInfluenceMaps }
|
||||
constructor TKMInfluences.Create(aNavMesh: TKMNavMesh);
|
||||
begin
|
||||
inherited Create();
|
||||
|
||||
fNavMesh := aNavMesh;
|
||||
fPolyCnt := 0;
|
||||
fUpdateCityIdx := 0;
|
||||
fUpdateArmyIdx := 0;
|
||||
fInfluenceFloodFill := TKMInfluenceFloodFill.Create(False); // Check if True is better
|
||||
fInfluenceSearch := TNavMeshInfluenceSearch.Create(False);
|
||||
{$IFDEF DEBUG_AIInfluences}
|
||||
fTimeAvrgOwnership := 0;
|
||||
fTimeAvrgPresence := 0;
|
||||
fTimePeakOwnership := 0;
|
||||
fTimePeakPresence := 0;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMInfluences.Destroy();
|
||||
begin
|
||||
fInfluenceFloodFill.Free;
|
||||
fInfluenceSearch.Free;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMInfluences.Save(SaveStream: TKMemoryStream);
|
||||
var
|
||||
K, Len: Integer;
|
||||
begin
|
||||
|
||||
SaveStream.PlaceMarker('Influences');
|
||||
SaveStream.Write(fMapX);
|
||||
SaveStream.Write(fMapY);
|
||||
SaveStream.Write(fPolyCnt);
|
||||
SaveStream.Write(fUpdateCityIdx,SizeOf(fUpdateCityIdx));
|
||||
SaveStream.Write(fUpdateArmyIdx,SizeOf(fUpdateArmyIdx));
|
||||
|
||||
SaveStream.PlaceMarker('Alliances');
|
||||
SaveStream.Write( Integer(Length(fAlli2PL)) );
|
||||
for K := Low(fAlli2PL) to High(fAlli2PL) do
|
||||
begin
|
||||
SaveStream.Write( Integer(Length(fAlli2PL[K])) );
|
||||
SaveStream.Write(fAlli2PL[K,0], SizeOf(fAlli2PL[K,0])*Length(fAlli2PL[K]));
|
||||
end;
|
||||
|
||||
SaveStream.PlaceMarker('AvoidBuilding');
|
||||
SaveStream.Write(fAvoidBuilding[0], SizeOf(fAvoidBuilding[0]) * Length(fAvoidBuilding));
|
||||
|
||||
SaveStream.PlaceMarker('Ownership');
|
||||
Len := Length(fOwnership);
|
||||
SaveStream.Write(Len);
|
||||
if Len > 0 then
|
||||
SaveStream.Write(fOwnership[0], SizeOf(fOwnership[0]) * Len);
|
||||
|
||||
SaveStream.PlaceMarker('ArmyPresence');
|
||||
Len := Length(fPresence);
|
||||
SaveStream.Write(Len);
|
||||
if Len > 0 then
|
||||
SaveStream.Write(fPresence[0], SizeOf(fPresence[0]) * Len);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMInfluences.Load(LoadStream: TKMemoryStream);
|
||||
var
|
||||
K, Len: Integer;
|
||||
begin
|
||||
LoadStream.CheckMarker('Influences');
|
||||
LoadStream.Read(fMapX);
|
||||
LoadStream.Read(fMapY);
|
||||
LoadStream.Read(fPolyCnt);
|
||||
LoadStream.Read(fUpdateCityIdx,SizeOf(fUpdateCityIdx));
|
||||
LoadStream.Read(fUpdateArmyIdx,SizeOf(fUpdateArmyIdx));
|
||||
|
||||
LoadStream.CheckMarker('Alliances');
|
||||
LoadStream.Read(Len);
|
||||
SetLength(fAlli2PL, Len);
|
||||
for K := Low(fAlli2PL) to High(fAlli2PL) do
|
||||
begin
|
||||
LoadStream.Read(Len);
|
||||
SetLength(fAlli2PL[K],Len);
|
||||
LoadStream.Read(fAlli2PL[K,0], SizeOf(fAlli2PL[K,0])*Length(fAlli2PL[K]));
|
||||
end;
|
||||
|
||||
LoadStream.CheckMarker('AvoidBuilding');
|
||||
SetLength(fAvoidBuilding, fMapY * fMapX);
|
||||
LoadStream.Read(fAvoidBuilding[0], SizeOf(fAvoidBuilding[0]) * fMapY * fMapX);
|
||||
|
||||
LoadStream.CheckMarker('Ownership');
|
||||
LoadStream.Read(Len);
|
||||
SetLength(fOwnership, Len);
|
||||
if Len > 0 then
|
||||
LoadStream.Read(fOwnership[0], SizeOf(fOwnership[0]) * Len);
|
||||
|
||||
LoadStream.CheckMarker('ArmyPresence');
|
||||
LoadStream.Read(Len);
|
||||
SetLength(fPresence, Len);
|
||||
if Len > 0 then
|
||||
LoadStream.Read(fPresence[0], SizeOf(fPresence[0]) * Len);
|
||||
end;
|
||||
|
||||
|
||||
//Make the area around to be avoided by common houses
|
||||
procedure TKMInfluences.AddAvoidBuilding(aX,aY: Word; aRad: Single);
|
||||
var
|
||||
X,Y,Rad: Integer;
|
||||
begin
|
||||
if (aRad = 0) then
|
||||
Exit;
|
||||
Rad := Ceil(aRad);
|
||||
for Y := Max(aY - Rad, 1) to Min(aY + Rad, fMapY - 1) do
|
||||
for X := Max(aX - Rad, 1) to Min(aX + Rad, fMapX - 1) do
|
||||
if (AvoidBuilding[Y,X] = 0) OR (AvoidBuilding[Y,X] >= AVOID_BUILDING_FOREST_MINIMUM) // Protect reservation tiles
|
||||
AND (Sqr(aX-X) + Sqr(aY-Y) <= Sqr(aRad)) then
|
||||
AvoidBuilding[Y,X] := 255;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMInfluences.RemAvoidBuilding(aArea: TKMRect);
|
||||
var
|
||||
X,Y: Integer;
|
||||
begin
|
||||
for Y := Max(aArea.Top , 1) to Min(aArea.Bottom, fMapY - 1) do
|
||||
for X := Max(aArea.Left, 1) to Min(aArea.Right , fMapX - 1) do
|
||||
if (AvoidBuilding[Y,X] = AVOID_BUILDING_COAL_TILE) then // It is not used otherwise anyway
|
||||
AvoidBuilding[Y,X] := 0;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMInfluences.MarkForest(aPoint: TKMPoint; aRad, aDecreaseCoef: Single; aOnlyUnmarkedArea: Boolean = False);
|
||||
var
|
||||
X,Y, Rad: Integer;
|
||||
SqrDist, SqrMaxDist: Single;
|
||||
begin
|
||||
if (aRad = 0) then
|
||||
Exit;
|
||||
SqrMaxDist := Sqr(aRad);
|
||||
Rad := Ceil(aRad);
|
||||
for Y := Max(aPoint.Y - Rad, 1) to Min(aPoint.Y + Rad, fMapY - 1) do
|
||||
for X := Max(aPoint.X - Rad, 1) to Min(aPoint.X + Rad, fMapX - 1) do
|
||||
if (AvoidBuilding[Y,X] = 0) OR (AvoidBuilding[Y,X] >= AVOID_BUILDING_FOREST_MINIMUM) then // Protect reservation tiles
|
||||
begin
|
||||
SqrDist := Sqr(aPoint.X-X) + Sqr(aPoint.Y-Y);
|
||||
if (SqrDist <= SqrMaxDist) then
|
||||
begin
|
||||
if not aOnlyUnmarkedArea then
|
||||
AvoidBuilding[Y,X] := Min( 254, // Forest does not reach full 255
|
||||
Max( AVOID_BUILDING_FOREST_MINIMUM, // Forest start at this value
|
||||
AvoidBuilding[Y,X] + 254 - Round(SqrDist * aDecreaseCoef)
|
||||
)
|
||||
)
|
||||
else if (AvoidBuilding[Y,X] = 0) then
|
||||
AvoidBuilding[Y,X] := Min( 254, // Forest does not reach full 255
|
||||
Max( AVOID_BUILDING_FOREST_MINIMUM, // Forest start at this value
|
||||
254 - Round(SqrDist * aDecreaseCoef)
|
||||
)
|
||||
);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
//AI should avoid certain areas, keeping them for special houses
|
||||
procedure TKMInfluences.InitAvoidBuilding();
|
||||
procedure CheckAndMarkMine(aX,aY: Integer; aHT: TKMHouseType);
|
||||
var
|
||||
X,Y,X2,Y2: Integer;
|
||||
begin
|
||||
for Y := Max(1,aY-3) to Min(fMapY-1,aY-1) do
|
||||
for X := Max(1,aX-1) to Min(fMapX-1,aX+1) do
|
||||
if ((aHT = htIronMine) AND (gTerrain.TileIsIron(X,Y) > 1))
|
||||
OR ((aHT = htGoldMine) AND (gTerrain.TileIsGold(X,Y) > 1)) then
|
||||
begin
|
||||
for Y2 := aY to Min(fMapY-1,aY+1) do
|
||||
for X2 := Max(1,aX-2) to Min(fMapX-1,aX+1+Byte(aHT = htIronMine)) do
|
||||
AvoidBuilding[Y2, X2] := AVOID_BUILDING_MINE_TILE;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
var
|
||||
H: TKMHouse;
|
||||
I,X,Y: Integer;
|
||||
begin
|
||||
FillChar(fAvoidBuilding[0], SizeOf(fAvoidBuilding[0]) * Length(fAvoidBuilding), #0);
|
||||
|
||||
//Avoid Coal fields (must be BEFORE Gold/Iron mines)
|
||||
for Y := 1 to fMapY - 1 do
|
||||
for X := 1 to fMapX - 1 do
|
||||
if (gTerrain.TileIsCoal(X, Y) > 1) then
|
||||
AvoidBuilding[Y,X] := AVOID_BUILDING_COAL_TILE;
|
||||
|
||||
//Avoid areas where Gold/Iron mines should be
|
||||
for Y := 3 to fMapY - 2 do
|
||||
for X := 2 to fMapX - 2 do
|
||||
if gTerrain.CanPlaceHouse(KMPoint(X,Y), htIronMine) then
|
||||
CheckAndMarkMine(X,Y, htIronMine)
|
||||
else if gTerrain.CanPlaceHouse(KMPoint(X,Y), htGoldMine) then
|
||||
CheckAndMarkMine(X,Y, htGoldMine);
|
||||
|
||||
//Leave free space BELOW all Stores
|
||||
for I := 0 to gHands.Count - 1 do
|
||||
begin
|
||||
H := gHands[I].FindHouse(htStore);
|
||||
if (H <> nil) then
|
||||
for Y := Max(H.Entrance.Y + 1, 1) to Min(H.Entrance.Y + 2, fMapY - 1) do
|
||||
for X := Max(H.Entrance.X - 1, 1) to Min(H.Entrance.X + 1, fMapX - 1) do
|
||||
AvoidBuilding[Y,X] := AVOID_BUILDING_HOUSE_ENTRANCE;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMInfluences.GetAvoidBuilding(const aY,aX: Word): Byte;
|
||||
begin
|
||||
Result := fAvoidBuilding[aY*fMapX + aX];
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMInfluences.SetAvoidBuilding(const aY,aX: Word; const aValue: Byte);
|
||||
begin
|
||||
fAvoidBuilding[aY*fMapX + aX] := aValue;
|
||||
end;
|
||||
|
||||
|
||||
function TKMInfluences.GetArmyTraffic(const aAlliance, aIdx: Word): Word;
|
||||
const
|
||||
MAX_SOLDIERS_IN_POLYGON = 20; // Maximal count of soldiers in 1 triangle of NavMesh - it depends on NavMesh size!!!
|
||||
begin
|
||||
Result := Min(MAX_SOLDIERS_IN_POLYGON, fPresence[PRESENCE_X*(aAlliance*fPolyCnt + aIdx) + AVOID_TRAFFIC_IDX]);
|
||||
end;
|
||||
|
||||
|
||||
function TKMInfluences.GetPresence(const aAlliance, aIdx: Word; const aGT: TKMGroupType): Word;
|
||||
begin
|
||||
Result := fPresence[PRESENCE_X*(aAlliance*fPolyCnt + aIdx) + Ord(aGT) - GROUP_TYPE_MIN_OFF];
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMInfluences.SetPresence(const aAlliance, aIdx: Word; const aGT: TKMGroupType; const aPresence: Word);
|
||||
begin
|
||||
fPresence[PRESENCE_X*(aAlliance*fPolyCnt + aIdx) + Ord(aGT) - GROUP_TYPE_MIN_OFF] := aPresence;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMInfluences.SetIncPresence(const aAlliance, aIdx: Word; const aGT: TKMGroupType; const aPresence: Word);
|
||||
begin
|
||||
Inc(fPresence[PRESENCE_X*(aAlliance*fPolyCnt + aIdx) + Ord(aGT) - GROUP_TYPE_MIN_OFF], aPresence);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMInfluences.UpdateMilitaryPresence(aAllianceIdx: Integer);
|
||||
const
|
||||
EACH_X_MEMBER_COEF = 5;
|
||||
PENALIZATION_ARR: array [GROUP_TYPE_MIN..GROUP_TYPE_MAX, GROUP_TYPE_MIN..GROUP_TYPE_MAX] of Single = (
|
||||
// gtMelee, gtAntiHorse, gtRanged, gtMounted
|
||||
( 1.0, 0.3, 0.0, 0.5), // gtMelee
|
||||
( 1.0, 1.0, 0.0, 0.0), // gtAntiHorse
|
||||
( 1.0, 1.0, 1.0, 2.0), // gtRanged
|
||||
( 1.0, 2.0, 0.0, 1.0) // gtMounted
|
||||
);
|
||||
procedure EvaluatePolygon(aIdx: Cardinal; aEval: Word; aGT: TKMGroupType);
|
||||
begin
|
||||
Inc(fPresence[aIdx+0], Round(aEval*PENALIZATION_ARR[aGT,gtMelee]));
|
||||
Inc(fPresence[aIdx+1], Round(aEval*PENALIZATION_ARR[aGT,gtAntiHorse]));
|
||||
Inc(fPresence[aIdx+2], Round(aEval*PENALIZATION_ARR[aGT,gtRanged]));
|
||||
Inc(fPresence[aIdx+3], Round(aEval*PENALIZATION_ARR[aGT,gtMounted]));
|
||||
end;
|
||||
var
|
||||
Increment: Word;
|
||||
K, L, M, PolyIdx: Integer;
|
||||
G: TKMUnitGroup;
|
||||
GT: TKMGroupType;
|
||||
U: TKMUnit;
|
||||
PL: TKMHandID;
|
||||
begin
|
||||
if (Length(fPresence) <= 0) then
|
||||
Exit;
|
||||
// Length of fPresence = alliances * polygons * 5 (= 4 types of groups + traffic)
|
||||
FillChar(fPresence[aAllianceIdx*fPolyCnt*PRESENCE_X], SizeOf(fPresence[0]) * fPolyCnt * PRESENCE_X, #0);
|
||||
|
||||
// Mark avoid traffic
|
||||
for PL in fAlli2PL[aAllianceIdx] do
|
||||
if gHands[PL].Enabled then
|
||||
for K := 0 to gHands[PL].UnitGroups.Count - 1 do
|
||||
begin
|
||||
G := gHands[PL].UnitGroups.Groups[K];
|
||||
if (G = nil) or G.IsDead then
|
||||
Continue;
|
||||
Increment := Min(G.Count, EACH_X_MEMBER_COEF);
|
||||
L := 0;
|
||||
while (L < G.Count) do
|
||||
begin
|
||||
U := G.Members[L];
|
||||
if (U <> nil) and not U.IsDeadOrDying then
|
||||
begin
|
||||
PolyIdx := fNavMesh.KMPoint2Polygon[U.Position];
|
||||
Inc(fPresence[PRESENCE_X*(aAllianceIdx*fPolyCnt + PolyIdx) + AVOID_TRAFFIC_IDX],Increment);
|
||||
end;
|
||||
L := L + EACH_X_MEMBER_COEF;
|
||||
end;
|
||||
end;
|
||||
|
||||
// Mark enemy groups
|
||||
for PL := 0 to gHands.Count - 1 do
|
||||
if gHands[PL].Enabled and (gHands[fAlli2PL[aAllianceIdx,0]].Alliances[PL] = atEnemy) then
|
||||
for K := 0 to gHands[PL].UnitGroups.Count - 1 do
|
||||
begin
|
||||
G := gHands[PL].UnitGroups.Groups[K];
|
||||
if (G = nil) or G.IsDead then
|
||||
Continue;
|
||||
Increment := Min(G.Count, EACH_X_MEMBER_COEF);
|
||||
GT := G.GroupType;
|
||||
L := 0;
|
||||
while (L < G.Count) do
|
||||
begin
|
||||
U := G.Members[L];
|
||||
if (U <> nil) and not U.IsDeadOrDying then
|
||||
begin
|
||||
PolyIdx := fNavMesh.KMPoint2Polygon[U.Position];
|
||||
EvaluatePolygon(PRESENCE_X*(aAllianceIdx*fPolyCnt + PolyIdx), Increment, GT);
|
||||
with fNavMesh.Polygons[PolyIdx] do
|
||||
for M := 0 to NearbyCount - 1 do
|
||||
EvaluatePolygon(PRESENCE_X*(aAllianceIdx*fPolyCnt + Nearby[M]), Increment, GT);
|
||||
end;
|
||||
L := L + EACH_X_MEMBER_COEF;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMInfluences.GetOwnership(const aPL: TKMHandID; const aIdx: Word): Byte;
|
||||
begin
|
||||
Result := fOwnership[aPL * fPolyCnt + aIdx];
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMInfluences.SetOwnership(const aPL: TKMHandID; const aIdx: Word; const aOwnership: Byte);
|
||||
begin
|
||||
fOwnership[aPL * fPolyCnt + aIdx] := aOwnership;
|
||||
end;
|
||||
|
||||
|
||||
function TKMInfluences.GetOwnershipFromCoords(const aPL: TKMHandID; const aY, aX: Word): Byte;
|
||||
begin
|
||||
Result := GetOwnership(aPL, fNavMesh.Point2Polygon[aY,aX]);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMInfluences.SetOwnershipFromCoords(const aPL: TKMHandID; const aY, aX: Word; const aOwnership: Byte);
|
||||
begin
|
||||
SetOwnership(aPL, fNavMesh.Point2Polygon[aY,aX], aOwnership);
|
||||
end;
|
||||
|
||||
|
||||
function TKMInfluences.GetOwnershipFromPoint(const aPL: TKMHandID; const aPoint: TKMPoint): Byte;
|
||||
begin
|
||||
Result := GetOwnership(aPL, fNavMesh.KMPoint2Polygon[aPoint]);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMInfluences.SetOwnershipFromPoint(const aPL: TKMHandID; const aPoint: TKMPoint; const aOwnership: Byte);
|
||||
begin
|
||||
SetOwnership(aPL, fNavMesh.KMPoint2Polygon[aPoint], aOwnership);
|
||||
end;
|
||||
|
||||
|
||||
function TKMInfluences.GetBestOwner(const aX,aY: Word): TKMHandID;
|
||||
begin
|
||||
Result := GetBestOwner( fNavMesh.Point2Polygon[aY,aX] );
|
||||
end;
|
||||
|
||||
|
||||
function TKMInfluences.GetBestOwner(const aIdx: Word): TKMHandID;
|
||||
var
|
||||
PL: TKMHandID;
|
||||
Best: Integer;
|
||||
begin
|
||||
Result := HAND_NONE;
|
||||
if not FEAT_AI_GENERATE_INFLUENCE OR (aIdx = High(Word)) then
|
||||
Exit;
|
||||
|
||||
Best := 0;
|
||||
for PL := 0 to gHands.Count - 1 do
|
||||
if (OwnPoly[PL,aIdx] > Best) then
|
||||
begin
|
||||
Best := OwnPoly[PL,aIdx];
|
||||
Result := PL;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMInfluences.GetBestAllianceOwner(const aPL: TKMHandID; const aPoint: TKMPoint; const aAllianceType: TKMAllianceType): TKMHandID;
|
||||
var
|
||||
PL: TKMHandID;
|
||||
Idx: Word;
|
||||
Best: Integer;
|
||||
begin
|
||||
Result := HAND_NONE;
|
||||
Idx := fNavMesh.Point2Polygon[aPoint.Y,aPoint.X];
|
||||
if not FEAT_AI_GENERATE_INFLUENCE OR (Idx = High(Word)) then
|
||||
Exit;
|
||||
|
||||
Best := 0;
|
||||
for PL := 0 to gHands.Count - 1 do
|
||||
if (gHands[aPL].Alliances[PL] = aAllianceType) AND (OwnPoly[PL,Idx] > Best) then
|
||||
begin
|
||||
Best := OwnPoly[PL,Idx];
|
||||
Result := PL;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
//function TKMInfluences.GetAllAllianceOwnership(const aPL: TKMHandIndex; const aX,aY: Word; const aAllianceType: TKMAllianceType): TKMHandIndexArray;
|
||||
//var
|
||||
// PL: TKMHandIndex;
|
||||
// I,K,Idx, Cnt: Integer;
|
||||
// Output: TKMHandIndexArray;
|
||||
//begin
|
||||
// SetLength(Result,0);
|
||||
// if not FEAT_AI_GENERATE_INFLUENCE OR (aIdx = High(Word)) then
|
||||
// Exit;
|
||||
//
|
||||
// SetLength(Output, MAX_HANDS);
|
||||
// Cnt := 0;
|
||||
// Idx := fNavMesh.Point2Polygon[aY,aX];
|
||||
// for PL := 0 to gHands.Count - 1 do
|
||||
// if (aPL <> PL) AND (gHands[aPL].Alliances[PL] = aAllianceType) AND (OwnPoly[PL,Idx] > 0) then
|
||||
// begin
|
||||
// Output[Cnt] := OwnPoly[PL,Idx];
|
||||
// Cnt := Cnt + 1;
|
||||
// end;
|
||||
// SetLength(Output, MAX_HANDS);
|
||||
// // Sort results by influence (in real game 1 <-> 3 elements)
|
||||
// for I := Cnt - 1 downto 0 do
|
||||
// for K := 0 to I - 1 do
|
||||
// if (OwnPoly[ Output[K],Idx ] < OwnPoly[ Output[K+1],Idx ]) then
|
||||
// begin
|
||||
// PL := Output[K];
|
||||
// Output[K] := Output[K+1];
|
||||
// Output[K+1] := K;
|
||||
// end;
|
||||
// Result := Output;
|
||||
//end;
|
||||
|
||||
|
||||
function TKMInfluences.GetBestAllianceOwnership(const aPL: TKMHandID; const aX,aY: Word; const aAllianceType: TKMAllianceType): Byte;
|
||||
begin
|
||||
Result := GetBestAllianceOwnership(aPL, fNavMesh.Point2Polygon[aY,aX], aAllianceType);
|
||||
end;
|
||||
|
||||
|
||||
function TKMInfluences.GetBestAllianceOwnership(const aPL: TKMHandID; const aIdx: Word; const aAllianceType: TKMAllianceType): Byte;
|
||||
var
|
||||
PL: TKMHandID;
|
||||
begin
|
||||
Result := 0;
|
||||
if not FEAT_AI_GENERATE_INFLUENCE OR (aIdx = High(Word)) then
|
||||
Exit;
|
||||
|
||||
for PL := 0 to gHands.Count - 1 do
|
||||
if (aPL <> PL) AND (gHands[aPL].Alliances[PL] = aAllianceType) AND (OwnPoly[PL,aIdx] > Result) then
|
||||
Result := OwnPoly[PL,aIdx];
|
||||
end;
|
||||
|
||||
|
||||
function TKMInfluences.GetOtherOwnerships(const aPL: TKMHandID; const aX, aY: Word): Word;
|
||||
begin
|
||||
Result := GetOtherOwnerships(aPL, fNavMesh.Point2Polygon[aY,aX]);
|
||||
end;
|
||||
|
||||
|
||||
function TKMInfluences.GetOtherOwnerships(const aPL: TKMHandID; const aIdx: Word): Word;
|
||||
const
|
||||
ENEMY_COEF = 2;
|
||||
var
|
||||
PL: TKMHandID;
|
||||
Ownership: Byte;
|
||||
begin
|
||||
Result := 0;
|
||||
if not FEAT_AI_GENERATE_INFLUENCE OR (aIdx = High(Word)) then
|
||||
Exit;
|
||||
|
||||
Result := 0;
|
||||
for PL := 0 to gHands.Count - 1 do
|
||||
if (PL <> aPL) then
|
||||
begin
|
||||
Ownership := OwnPoly[PL,aIdx];
|
||||
Inc(Result, IfThen(gHands[aPL].Alliances[PL] = atAlly, Ownership, Ownership*ENEMY_COEF));
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMInfluences.CanPlaceHouseByInfluence(const aPL: TKMHandID; const aX,aY: Word; const aIgnoreAllies: Boolean = False): Boolean;
|
||||
begin
|
||||
Result := CanPlaceHouseByInfluence(aPL, fNavMesh.Point2Polygon[aY,aX], aIgnoreAllies);
|
||||
end;
|
||||
|
||||
|
||||
function TKMInfluences.CanPlaceHouseByInfluence(const aPL: TKMHandID; const aIdx: Word; const aIgnoreAllies: Boolean = False): Boolean;
|
||||
var
|
||||
bestOwner: TKMHandID;
|
||||
begin
|
||||
bestOwner := GetBestOwner(aIdx);
|
||||
Result := (bestOwner >= 0) AND (OwnPoly[aPL, aIdx] > 0) AND ((bestOwner = aPL) OR (not aIgnoreAllies AND (gHands[aPL].Alliances[bestOwner] = atAlly)));
|
||||
end;
|
||||
|
||||
|
||||
// Here is the main reason for reworking influences: only 1 flood fill for city per a update + ~25x less elements in array
|
||||
procedure TKMInfluences.UpdateOwnership(const aPL: TKMHandID);
|
||||
const
|
||||
INIT_HOUSE_INFLUENCE = 255;
|
||||
MAX_INFLUENCE_DISTANCE = 150;
|
||||
var
|
||||
isAI: Boolean;
|
||||
I, cnt: Integer;
|
||||
H: TKMHouse;
|
||||
idxArray: TKMWordArray;
|
||||
begin
|
||||
//Clear array (it is better to clear ~3000 polygons instead of 255*255 tiles)
|
||||
FillChar(fOwnership[aPL*fPolyCnt], SizeOf(fOwnership[0]) * fPolyCnt, #0);
|
||||
|
||||
// Create array of polygon indexes
|
||||
SetLength(idxArray, gHands[aPL].Houses.Count);
|
||||
cnt := 0;
|
||||
isAI := gHands[aPL].IsComputer;
|
||||
for I := 0 to gHands[aPL].Houses.Count - 1 do
|
||||
begin
|
||||
H := gHands[aPL].Houses[I];
|
||||
if not H.IsDestroyed
|
||||
and not (H.HouseType in [htWatchTower, htWoodcutters])
|
||||
and (isAI or H.IsComplete) then // Player must finish the house to update influence so he cannot troll the AI
|
||||
begin
|
||||
// Use point below entrance to match NavMeshDefence algorithm and city center detection in Eye
|
||||
idxArray[cnt] := fNavMesh.KMPoint2Polygon[H.PointBelowEntrance];
|
||||
Inc(cnt);
|
||||
end;
|
||||
end;
|
||||
|
||||
if cnt > 0 then
|
||||
fInfluenceFloodFill.HouseInfluence(aPL, INIT_HOUSE_INFLUENCE, MAX_INFLUENCE_DISTANCE, cnt - 1, idxArray);
|
||||
end;
|
||||
|
||||
|
||||
function TKMInfluences.GetAllianceIdx(const aPL: TKMHandID; var aIdx: Integer): Boolean;
|
||||
var
|
||||
K, PL: TKMHandID;
|
||||
begin
|
||||
Result := False;
|
||||
for K := Low(fAlli2PL) to High(fAlli2PL) do
|
||||
for PL in fAlli2PL[K] do
|
||||
if (PL = aPL) then
|
||||
begin
|
||||
aIdx := K;
|
||||
Exit(True);
|
||||
end
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMInfluences.InitInfluences();
|
||||
var
|
||||
Idx: Integer;
|
||||
PL: TKMHandID;
|
||||
begin
|
||||
fPolyCnt := fNavMesh.PolygonsCnt;
|
||||
if (Length(fOwnership) < gHands.Count * fPolyCnt) then
|
||||
SetLength(fOwnership, gHands.Count * fPolyCnt);
|
||||
FillChar(fOwnership[0], SizeOf(fOwnership[0]) * Length(fOwnership), #0);
|
||||
for PL := 0 to gHands.Count - 1 do
|
||||
UpdateOwnership(PL);
|
||||
SetLengthOfPresence();
|
||||
for Idx := 0 to Length(fAlli2PL) - 1 do
|
||||
UpdateMilitaryPresence(Idx);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMInfluences.AfterMissionInit();
|
||||
begin
|
||||
fMapX := gTerrain.MapX;
|
||||
fMapY := gTerrain.MapY;
|
||||
SetLength(fAvoidBuilding, fMapY * fMapX);
|
||||
InitAvoidBuilding();
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMInfluences.UpdateState(aTick: Cardinal);
|
||||
{$IFDEF DEBUG_AIInfluences}
|
||||
var
|
||||
tStart,tStop: Int64;
|
||||
procedure UpdateTimer(var aTimeAvrg, aTimePeak: Int64);
|
||||
begin
|
||||
tStop := TimeGetUsec() - tStart;
|
||||
aTimePeak := Max(aTimePeak, tStop);
|
||||
aTimeAvrg := Round((aTimeAvrg * 5 + tStop)/6);
|
||||
tStart := TimeGetUsec();
|
||||
end;
|
||||
{$ENDIF}
|
||||
begin
|
||||
{$IFDEF DEBUG_AIInfluences}
|
||||
tStart := TimeGetUsec();
|
||||
{$ENDIF}
|
||||
// City:
|
||||
if (aTick mod 150 = 15) then // Update every 15 sec 1 player
|
||||
begin
|
||||
fUpdateCityIdx := (fUpdateCityIdx + 1) mod gHands.Count;
|
||||
UpdateOwnership(fUpdateCityIdx);
|
||||
{$IFDEF DEBUG_AIInfluences}
|
||||
UpdateTimer(fTimeAvrgOwnership, fTimePeakOwnership);
|
||||
{$ENDIF}
|
||||
end;
|
||||
// Army:
|
||||
if (aTick mod 5 = 0) AND (Length(fAlli2PL) > 0) then // Update every 0.5 sec 1 player
|
||||
begin
|
||||
fUpdateArmyIdx := (fUpdateArmyIdx + 1) mod Length(fAlli2PL);
|
||||
UpdateMilitaryPresence(fUpdateArmyIdx);
|
||||
{$IFDEF DEBUG_AIInfluences}
|
||||
UpdateTimer(fTimeAvrgPresence, fTimePeakPresence);
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMInfluences.UpdateAlliances(const aAlli2PL: TKMHandID2Array);
|
||||
var
|
||||
K: Integer;
|
||||
begin
|
||||
SetLength(fAlli2PL, Length(aAlli2PL));
|
||||
for K := Low(aAlli2PL) to High(aAlli2PL) do
|
||||
begin
|
||||
SetLength(fAlli2PL[K], Length(aAlli2PL[K]));
|
||||
Move(aAlli2PL[K,0], fAlli2PL[K,0], SizeOf(aAlli2PL[K,0]) * Length(aAlli2PL[K]));
|
||||
end;
|
||||
SetLengthOfPresence();
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMInfluences.SetLengthOfPresence();
|
||||
begin
|
||||
if (Length(fAlli2PL) * fPolyCnt * PRESENCE_X <> Length(fPresence)) then
|
||||
begin
|
||||
SetLength(fPresence, Length(fAlli2PL) * fPolyCnt * PRESENCE_X);
|
||||
FillChar(fPresence[0], SizeOf(fPresence[0]) * Length(fPresence), #0);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
//Render debug symbols
|
||||
procedure TKMInfluences.Paint(const aRect: TKMRect);
|
||||
var
|
||||
PL, WatchedPL: TKMHandID;
|
||||
K, X,Y, TeamIdx, Cnt: Integer;
|
||||
GT: TKMGroupType;
|
||||
Col: Cardinal;
|
||||
begin
|
||||
|
||||
if not FEAT_AI_GENERATE_NAVMESH OR not FEAT_AI_GENERATE_INFLUENCE then
|
||||
Exit;
|
||||
|
||||
if OVERLAY_AVOID then
|
||||
for Y := aRect.Top to aRect.Bottom do
|
||||
for X := aRect.Left to aRect.Right do
|
||||
begin
|
||||
Col := AvoidBuilding[Y,X] * 65793 OR $80000000;
|
||||
gRenderAux.Quad(X, Y, Col);
|
||||
end;
|
||||
|
||||
if (OVERLAY_INFLUENCE OR OVERLAY_OWNERSHIP) AND not OVERLAY_AI_COMBAT then
|
||||
begin
|
||||
for K := 0 to fPolyCnt - 1 do
|
||||
begin
|
||||
PL := GetBestOwner(K);
|
||||
if (PL = HAND_NONE) then
|
||||
Continue
|
||||
else
|
||||
fNavMesh.DrawPolygon(K, OwnPoly[PL,K], gHands[PL].FlagColor AND tcWhite);
|
||||
end;
|
||||
end;
|
||||
|
||||
if (OVERLAY_INFLUENCE OR OVERLAY_OWNERSHIP) AND OVERLAY_AI_COMBAT then
|
||||
begin
|
||||
WatchedPL := gMySpectator.HandID;
|
||||
if (WatchedPL = HAND_NONE) then
|
||||
Exit;
|
||||
|
||||
if not GetAllianceIdx(WatchedPL,TeamIdx) then
|
||||
Exit;
|
||||
|
||||
for K := 0 to fPolyCnt - 1 do
|
||||
begin
|
||||
Cnt := 0;
|
||||
for GT := GROUP_TYPE_MIN to GROUP_TYPE_MAX do
|
||||
Cnt := Cnt + Presence[TeamIdx, K, GT];
|
||||
//NavMesh polys coverage
|
||||
if (Cnt > 0) then
|
||||
fNavMesh.DrawPolygon(K, Byte(Min(Max(Cnt,$1F),$F0)), tcRed);
|
||||
Cnt := GetArmyTraffic(TeamIdx, K);
|
||||
//NavMesh polys coverage
|
||||
if (Cnt > 0) then
|
||||
fNavMesh.DrawPolygon(K, Byte(Min(Max(Cnt,$3F),$F0)), tcYellow);
|
||||
end;
|
||||
{
|
||||
for I := 0 to fPolyCnt - 1 do
|
||||
begin
|
||||
BestCnt := 0;
|
||||
for PL := 0 to gHands.Count - 1 do
|
||||
begin
|
||||
Cnt := PresenceAllGroups[PL,I];
|
||||
if (Cnt > BestCnt) then
|
||||
begin
|
||||
BestCnt := Cnt;
|
||||
if (WatchedPL = PL) then
|
||||
Col := tcGreen
|
||||
else if (gHands[WatchedPL].Alliances[PL] = atAlly) then
|
||||
Col := tcBlue
|
||||
else
|
||||
Col := tcRed;
|
||||
end;
|
||||
end;
|
||||
if (BestCnt > 0) then
|
||||
begin
|
||||
BestCnt := Min(BestCnt,$9F);
|
||||
//NavMesh polys coverage
|
||||
fNavMesh.DrawPolygon(I, BestCnt, Col);
|
||||
end;
|
||||
end;
|
||||
//}
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
+1053
File diff suppressed because it is too large.
Load diff
+1077
File diff suppressed because it is too large.
Load diff
+214
@@ -0,0 +1,214 @@
|
||||
unit KM_AISetup;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
KM_CommonClasses, KM_Defaults, KM_Points, KM_AITypes;
|
||||
|
||||
|
||||
type
|
||||
// Common AI settings
|
||||
// Could be a record, but we want to have default values initialization in constructor
|
||||
TKMHandAISetup = class
|
||||
private
|
||||
fNewAI: Boolean; // Enable advanced AI
|
||||
fRepairMode: TKMAIRepairMode;
|
||||
function GetNewAI: Boolean;
|
||||
function GetIsRepairAlways: Boolean;
|
||||
public
|
||||
Aggressiveness: Integer; //-1 means not used or default
|
||||
AutoAttack: Boolean;
|
||||
|
||||
AutoBuild: Boolean; // Enable build
|
||||
AutoDefend: Boolean;
|
||||
DefendAllies: Boolean;
|
||||
UnlimitedEquip: Boolean;
|
||||
ArmyType: TKMArmyType;
|
||||
EquipRateLeather, EquipRateIron: Word; //Number of ticks between soldiers being equipped. Separated into Leather/Iron to keep KaM compatibility.
|
||||
MaxSoldiers: Integer; //-1 means not used or default
|
||||
RecruitDelay: Cardinal; //Recruits (for barracks) can only be trained after this many ticks
|
||||
RecruitCount: Byte;
|
||||
SerfsPerHouse: Single;
|
||||
StartPosition: TKMPoint; //Defines roughly where to defend and build around
|
||||
TownDefence: Integer; //-1 means not used or default
|
||||
WorkerCount: Byte;
|
||||
AutoAttackRange: Byte; // Auto attack range for close combat warriors (used in KM_UnitWarrior)
|
||||
|
||||
constructor Create;
|
||||
|
||||
property NewAI: Boolean read GetNewAI write fNewAI;
|
||||
property RepairMode: TKMAIRepairMode read fRepairMode write fRepairMode;
|
||||
property IsRepairAlways: Boolean read GetIsRepairAlways;
|
||||
|
||||
function GetEquipRate(aUnit: TKMUnitType): Word;
|
||||
function WarriorsPerMinute(aArmy: TKMArmyType): Single; overload;
|
||||
function WarriorsPerMinute: Single; overload;
|
||||
|
||||
procedure ApplyMultiplayerSetup(aNewAI: Boolean);
|
||||
procedure EnableAdvancedAI(aNewAI: Boolean = True);
|
||||
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure Load(LoadStream: TKMemoryStream);
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Math;
|
||||
|
||||
|
||||
{ TKMHandAISetup }
|
||||
constructor TKMHandAISetup.Create;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
//TSK/TPR properties
|
||||
Aggressiveness := 100; //No idea what the default for this is, it's barely used
|
||||
AutoAttack := False; //It did not exist in KaM, we add it, Off by default
|
||||
AutoBuild := True; //In KaM it is On by default, and most missions turn it off
|
||||
AutoDefend := False; //It did not exist in KaM, we add it, Off by default
|
||||
RepairMode := rmRepairNever;
|
||||
DefendAllies := False; //It did not exist in KaM, we add it, Off by default (tested by Lewin, AI doesn't defend allies in TPR)
|
||||
|
||||
ArmyType := atIronThenLeather; //By default make iron soldiers, and if that fails make leather (same as TPR)
|
||||
EquipRateIron := 500; //Measured in KaM: AI equips 1 iron soldier every ~50 seconds
|
||||
EquipRateLeather := 1000; //Measured in KaM: AI equips 1 leather soldier every ~100 seconds (if no iron one was already equipped)
|
||||
MaxSoldiers := -1; //No limit by default
|
||||
WorkerCount := 6;
|
||||
RecruitCount := 5; //This means the number in the barracks, watchtowers are counted separately
|
||||
RecruitDelay := 0; //Can train at start
|
||||
SerfsPerHouse := 1;
|
||||
StartPosition := TKMPoint.New(1,1);
|
||||
TownDefence := 100; //In KaM 100 is standard, although we don't completely understand this command
|
||||
AutoAttackRange := 4; //Measured in TPR
|
||||
end;
|
||||
|
||||
|
||||
function TKMHandAISetup.GetEquipRate(aUnit: TKMUnitType): Word;
|
||||
begin
|
||||
if aUnit in WARRIORS_IRON then
|
||||
Result := EquipRateIron
|
||||
else
|
||||
Result := EquipRateLeather;
|
||||
end;
|
||||
|
||||
|
||||
function TKMHandAISetup.GetIsRepairAlways: Boolean;
|
||||
begin
|
||||
Result := fRepairMode = rmRepairAlways;
|
||||
end;
|
||||
|
||||
|
||||
function TKMHandAISetup.GetNewAI: Boolean;
|
||||
begin
|
||||
if Self = nil then Exit(False);
|
||||
|
||||
Result := fNewAI;
|
||||
end;
|
||||
|
||||
|
||||
function TKMHandAISetup.WarriorsPerMinute(aArmy: TKMArmyType): Single;
|
||||
|
||||
function EquipRateToPerMin(EquipRate: Cardinal): Single;
|
||||
begin
|
||||
Result := EnsureRange(600 / Max(EquipRate, 1), 0.1, 6);
|
||||
end;
|
||||
|
||||
begin
|
||||
case aArmy of
|
||||
atIronThenLeather: Result := Max(EquipRateToPerMin(EquipRateLeather), EquipRateToPerMin(EquipRateIron));
|
||||
atLeather: Result := EquipRateToPerMin(EquipRateLeather);
|
||||
atIron: Result := EquipRateToPerMin(EquipRateIron);
|
||||
atIronAndLeather: Result := EquipRateToPerMin(EquipRateLeather) + EquipRateToPerMin(EquipRateIron);
|
||||
else Result := 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMHandAISetup.WarriorsPerMinute: Single;
|
||||
begin
|
||||
Result := WarriorsPerMinute(ArmyType);
|
||||
end;
|
||||
|
||||
|
||||
//Used from MapEd to give multiplayer building maps an AI builder config
|
||||
procedure TKMHandAISetup.ApplyMultiplayerSetup(aNewAI: Boolean);
|
||||
begin
|
||||
SerfsPerHouse := 1;
|
||||
WorkerCount := 20;
|
||||
ArmyType := atIronAndLeather; //Mixed army
|
||||
EquipRateLeather := 500;
|
||||
EquipRateIron := 500;
|
||||
AutoBuild := True;
|
||||
RepairMode := rmRepairAlways;
|
||||
AutoAttack := True;
|
||||
AutoDefend := True;
|
||||
DefendAllies := True;
|
||||
UnlimitedEquip := True;
|
||||
StartPosition := TKMPoint.New(1,1); //So it is overridden by auto attack
|
||||
MaxSoldiers := -1;
|
||||
RecruitDelay := 0;
|
||||
RecruitCount := 10;
|
||||
AutoAttackRange := 6;
|
||||
EnableAdvancedAI(aNewAI);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMHandAISetup.EnableAdvancedAI(aNewAI: Boolean = True);
|
||||
begin
|
||||
NewAI := aNewAI;
|
||||
if NewAI then
|
||||
AutoAttackRange := 0; // It force units to attack the closest enemy (it should decide AI not command)
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMHandAISetup.Save(SaveStream: TKMemoryStream);
|
||||
begin
|
||||
SaveStream.PlaceMarker('AISetup');
|
||||
SaveStream.Write(fNewAI);
|
||||
SaveStream.Write(Aggressiveness);
|
||||
SaveStream.Write(AutoAttack);
|
||||
SaveStream.Write(AutoBuild);
|
||||
SaveStream.Write(fRepairMode, SizeOf(fRepairMode));
|
||||
SaveStream.Write(AutoDefend);
|
||||
SaveStream.Write(DefendAllies);
|
||||
SaveStream.Write(UnlimitedEquip);
|
||||
SaveStream.Write(ArmyType, SizeOf(ArmyType));
|
||||
SaveStream.Write(EquipRateLeather);
|
||||
SaveStream.Write(EquipRateIron);
|
||||
SaveStream.Write(MaxSoldiers);
|
||||
SaveStream.Write(RecruitDelay);
|
||||
SaveStream.Write(RecruitCount);
|
||||
SaveStream.Write(SerfsPerHouse);
|
||||
SaveStream.Write(StartPosition);
|
||||
SaveStream.Write(TownDefence);
|
||||
SaveStream.Write(WorkerCount);
|
||||
SaveStream.Write(AutoAttackRange);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMHandAISetup.Load(LoadStream: TKMemoryStream);
|
||||
begin
|
||||
LoadStream.CheckMarker('AISetup');
|
||||
LoadStream.Read(fNewAI);
|
||||
LoadStream.Read(Aggressiveness);
|
||||
LoadStream.Read(AutoAttack);
|
||||
LoadStream.Read(AutoBuild);
|
||||
LoadStream.Read(fRepairMode, SizeOf(fRepairMode));
|
||||
LoadStream.Read(AutoDefend);
|
||||
LoadStream.Read(DefendAllies);
|
||||
LoadStream.Read(UnlimitedEquip);
|
||||
LoadStream.Read(ArmyType, SizeOf(ArmyType));
|
||||
LoadStream.Read(EquipRateLeather);
|
||||
LoadStream.Read(EquipRateIron);
|
||||
LoadStream.Read(MaxSoldiers);
|
||||
LoadStream.Read(RecruitDelay);
|
||||
LoadStream.Read(RecruitCount);
|
||||
LoadStream.Read(SerfsPerHouse);
|
||||
LoadStream.Read(StartPosition);
|
||||
LoadStream.Read(TownDefence);
|
||||
LoadStream.Read(WorkerCount);
|
||||
LoadStream.Read(AutoAttackRange);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
+47
@@ -0,0 +1,47 @@
|
||||
unit KM_AITypes;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
|
||||
type
|
||||
//* AI defence position type
|
||||
// For now IDs must match with KaM
|
||||
TKMAIDefencePosType = (dtFrontLine, //Front line troops may not go on attacks, they are for defence
|
||||
dtBackLine); //Back line troops may attack
|
||||
//* AI attack type
|
||||
TKMAIAttackType = (
|
||||
aatOnce, // Attack will occur once (after the set time has passed and if they have enough troops
|
||||
aatRepeating // Attack will happen multiple times, (after delay time) whenever the AI has enough troops
|
||||
);
|
||||
|
||||
//* AI attack target
|
||||
//Indexes must match with KaM script values (for now)
|
||||
TKMAIAttackTarget = (attClosestUnit, //Closest enemy unit (untested as to whether this is relative to army or start position)
|
||||
attClosestBuildingFromArmy, //Closest building from the group(s) lauching the attack
|
||||
attClosestBuildingFromStartPos, //Closest building from the AI's start position
|
||||
attCustomPosition); //Custom point defined with CustomPosition
|
||||
|
||||
TKMFormation = record
|
||||
NumUnits: Integer;
|
||||
UnitsPerRow: Integer;
|
||||
procedure CopyFrom(aFormation: TKMFormation);
|
||||
end;
|
||||
|
||||
//* House repair mode
|
||||
TKMAIRepairMode = (
|
||||
rmNone,
|
||||
rmRepairNever, // disable AI repair for all houses
|
||||
rmRepairAlways, // enable AI repair for all houses
|
||||
rmRepairManual); // repair state is set by script manually via Actions.HouseRepairEnable
|
||||
|
||||
implementation
|
||||
|
||||
{ TKMFormation }
|
||||
procedure TKMFormation.CopyFrom(aFormation: TKMFormation);
|
||||
begin
|
||||
NumUnits := aFormation.NumUnits;
|
||||
UnitsPerRow := aFormation.UnitsPerRow;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
+762
@@ -0,0 +1,762 @@
|
||||
{
|
||||
Artificial intelligence
|
||||
@author: Martin Toupal
|
||||
@e-mail: poznamenany@gmail.com
|
||||
}
|
||||
unit KM_AIParameters;
|
||||
{$I KaM_Remake.inc}
|
||||
|
||||
interface
|
||||
uses
|
||||
SysUtils
|
||||
{$IFDEF PARALLEL_RUNNER}, KM_CommonClasses;
|
||||
{$ELSE};
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF PARALLEL_RUNNER}
|
||||
procedure LoadGAParameters(LoadStream: TKMemoryStream);
|
||||
procedure SaveGAParameters(SaveStream: TKMemoryStream);
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
// AI parameters in enumerations
|
||||
type
|
||||
|
||||
TAIPar = (
|
||||
|
||||
ATTACK_ArmyVectorField_START
|
||||
,ATTACK_ArmyVectorField_FindPositions_DistEnemyOffset
|
||||
,ATTACK_ArmyVectorField_FindPositions_DistEnemyOffsetFF
|
||||
,ATTACK_ArmyVectorField_FindPositions_DistEnemyGainFF
|
||||
,ATTACK_ArmyVectorField_FindPositions_DistCloseToEnemy
|
||||
,ATTACK_ArmyVectorField_FindPositions_DistMaxWalk
|
||||
,ATTACK_ArmyVectorField_FindPositions_FollowEnemyVectorFieldUth
|
||||
,ATTACK_ArmyVectorField_FindPositions_AvoidTraffic
|
||||
,ATTACK_ArmyVectorField_FindPositions_RallyPointOffset
|
||||
,ATTACK_ArmyVectorField_EvalClusters_InPlace
|
||||
,ATTACK_ArmyVectorField_EvalClusters_AtAdvantage
|
||||
,ATTACK_ArmyVectorField_EvalClusters_Ambushed
|
||||
,ATTACK_ArmyVectorField_DivideForces_DefendCityAdv
|
||||
,ATTACK_ArmyVectorField_DivideForces_SupportAllyAdv
|
||||
,ATTACK_ArmyVectorField_END
|
||||
|
||||
,ATTACK_SQUAD_START
|
||||
,ATTACK_SQUAD_ChangeTarget_Delay
|
||||
,ATTACK_SQUAD_MinWalkingDistance
|
||||
,ATTACK_SQUAD_TargetReached_House
|
||||
,ATTACK_SQUAD_TargetReached_Position
|
||||
,ATTACK_SQUAD_TargetReached_RangedSquad
|
||||
,ATTACK_SQUAD_TargetReached_Unit
|
||||
,ATTACK_SQUAD_TrafficDetection_Limit
|
||||
,ATTACK_SQUAD_TrafficDetection_Threshold
|
||||
,ATTACK_SQUAD_END
|
||||
|
||||
,ATTACK_SUPERVISOR_START
|
||||
,ATTACK_SUPERVISOR_EvalTarget_DistanceGroup
|
||||
,ATTACK_SUPERVISOR_EvalTarget_OpportunityDistGain
|
||||
,ATTACK_SUPERVISOR_EvalTarget_OpportunityGain
|
||||
,ATTACK_SUPERVISOR_EvalTarget_DecreaseRisk
|
||||
,ATTACK_SUPERVISOR_EvalTarget_ThreatGainAntiHorse
|
||||
,ATTACK_SUPERVISOR_EvalTarget_ThreatGainDist
|
||||
,ATTACK_SUPERVISOR_EvalTarget_ThreatGainMelee
|
||||
,ATTACK_SUPERVISOR_EvalTarget_ThreatGainMounted
|
||||
,ATTACK_SUPERVISOR_EvalTarget_ThreatGainRangDist
|
||||
,ATTACK_SUPERVISOR_EvalTarget_ThreatGainRanged
|
||||
,ATTACK_SUPERVISOR_END
|
||||
|
||||
,NAVMESH_PATHFINDING_START
|
||||
,NAVMESH_PATHFINDING_AvoidTraffic
|
||||
,NAVMESH_PATHFINDING_LineLength
|
||||
,NAVMESH_PATHFINDING_AvoidSpecEnemy
|
||||
,NAVMESH_PATHFINDING_END
|
||||
|
||||
,BUILDER_START
|
||||
,BUILDER_BuildHouse_FieldMaxWork
|
||||
,BUILDER_BuildHouse_RTPMaxWork
|
||||
,BUILDER_BuildHouse_RoadMaxWork
|
||||
,BUILDER_ChHTB_AllWorkerCoef
|
||||
,BUILDER_ChHTB_FractionCoef
|
||||
,BUILDER_ChHTB_FreeWorkerCoef
|
||||
,BUILDER_ChHTB_TrunkBalance
|
||||
,BUILDER_ChHTB_TrunkFactor
|
||||
,BUILDER_CreateShortcuts_MaxWork
|
||||
,BUILDER_Shortage_Gold
|
||||
,BUILDER_Shortage_Stone
|
||||
,BUILDER_Shortage_StoneReserve
|
||||
,BUILDER_Shortage_Trunk
|
||||
,BUILDER_Shortage_Wood
|
||||
,BUILDER_END
|
||||
|
||||
,EYE_GetForests_START
|
||||
,EYE_GetForests_MaxAB
|
||||
,EYE_GetForests_MinRndSoil
|
||||
,EYE_GetForests_MinTrees
|
||||
,EYE_GetForests_Radius
|
||||
,EYE_GetForests_SPRndOwnLimMax
|
||||
,EYE_GetForests_SPRndOwnLimMin
|
||||
,EYE_GetForests_END
|
||||
|
||||
,MANAGEMENT_START
|
||||
,MANAGEMENT_CheckUnitCount_SerfGoldCoef
|
||||
,MANAGEMENT_CheckUnitCount_SerfLimit1
|
||||
,MANAGEMENT_CheckUnitCount_SerfLimit2
|
||||
,MANAGEMENT_CheckUnitCount_SerfLimit3
|
||||
,MANAGEMENT_CheckUnitCount_WorkerGoldCoef
|
||||
,MANAGEMENT_GoldShortage
|
||||
,MANAGEMENT_END
|
||||
|
||||
,PLANNER_FARM_START
|
||||
,PLANNER_FARM_FieldCrit_FlatArea
|
||||
,PLANNER_FARM_FieldCrit_PolyRoute
|
||||
,PLANNER_FARM_FieldCrit_Soil
|
||||
,PLANNER_FARM_FindPlaceForHouse_CityCenter
|
||||
,PLANNER_FARM_FindPlaceForHouse_FlatArea
|
||||
,PLANNER_FARM_FindPlaceForHouse_HouseDist
|
||||
,PLANNER_FARM_FindPlaceForHouse_Route
|
||||
,PLANNER_FARM_PlanFields_CanBuild
|
||||
,PLANNER_FARM_PlanFields_Dist
|
||||
,PLANNER_FARM_PlanFields_ExistField
|
||||
,PLANNER_FARM_END
|
||||
|
||||
,PLANNER_FindPlaceForHouse_START
|
||||
,PLANNER_FindPlaceForHouse_CityCenter
|
||||
,PLANNER_FindPlaceForHouse_FlatArea
|
||||
,PLANNER_FindPlaceForHouse_HouseDist
|
||||
,PLANNER_FindPlaceForHouse_Route
|
||||
,PLANNER_FindPlaceForHouse_SeedDist
|
||||
,PLANNER_FindPlaceForHouse_SnapCrit
|
||||
,PLANNER_FindPlaceForHouse_END
|
||||
|
||||
,PLANNER_FindPlaceForQuary_START
|
||||
,MANAGEMENT_CheckStoreWares_Stone
|
||||
,PREDICTOR_WareNeedPerAWorker_Stone
|
||||
,PREDICTOR_WareNeedPerAWorker_StoneOffset
|
||||
,PREDICTOR_WorkerCountCoef
|
||||
,PLANNER_FindPlaceForQuary_StoneLoc_StoneCnt
|
||||
,PLANNER_FindPlaceForQuary_StoneLoc_AlreadyMined
|
||||
,PLANNER_FindPlaceForQuary_StoneLoc_Distance
|
||||
,PLANNER_FindPlaceForQuary_DistCity
|
||||
,PLANNER_FindPlaceForQuary_DistStone
|
||||
,PLANNER_FindPlaceForQuary_DistTimer
|
||||
,PLANNER_FindPlaceForQuary_Obstacle
|
||||
,PLANNER_FindPlaceForQuary_SnapCrit
|
||||
,PLANNER_FindPlaceForQuary_QtyStone
|
||||
,PLANNER_FindPlaceForQuary_END
|
||||
|
||||
,PLANNER_FOREST_START
|
||||
,PLANNER_FOREST_FindForestAround_MaxDist
|
||||
,PLANNER_FOREST_FindPlaceForWoodcutter_ABRange
|
||||
,PLANNER_FOREST_FindPlaceForWoodcutter_DistCrit
|
||||
,PLANNER_FOREST_FindPlaceForWoodcutter_DistTimer
|
||||
,PLANNER_FOREST_FindPlaceForWoodcutter_ExistForest
|
||||
,PLANNER_FOREST_FindPlaceForWoodcutter_FlatArea
|
||||
,PLANNER_FOREST_FindPlaceForWoodcutter_FreeTiles
|
||||
,PLANNER_FOREST_FindPlaceForWoodcutter_Radius
|
||||
,PLANNER_FOREST_FindPlaceForWoodcutter_Routes
|
||||
,PLANNER_FOREST_FindPlaceForWoodcutter_Soil
|
||||
,PLANNER_FOREST_FindPlaceForWoodcutter_TreeCnt
|
||||
,PLANNER_FOREST_FindPlaceForWoodcutter_TreeCntTimer
|
||||
,PLANNER_FOREST_PlaceWoodcutter_DistFromForest
|
||||
,PLANNER_FOREST_END
|
||||
|
||||
,PLANNER_Snap_START
|
||||
,PLANNER_ObstaclesInHousePlan_Road
|
||||
,PLANNER_ObstaclesInHousePlan_Tree
|
||||
,PLANNER_SnapCrit_Field
|
||||
,PLANNER_SnapCrit_HouseOrRoad
|
||||
,PLANNER_SnapCrit_NoBuild
|
||||
,PLANNER_SnapCrit_ObstacleInEntrance
|
||||
,PLANNER_SnapCrit_Road
|
||||
,PLANNER_SnapCrit_RoadInEntrance
|
||||
,PLANNER_Snap_END
|
||||
|
||||
,PREDICTOR_START
|
||||
,PREDICTOR_SecondSchool_MinRequiredUnits
|
||||
,PREDICTOR_WareNeedPerAWorker_Wood
|
||||
,PREDICTOR_END
|
||||
|
||||
,SHORTCUTS_START
|
||||
,SHORTCUTS_BasePrice
|
||||
,SHORTCUTS_Coal
|
||||
,SHORTCUTS_Field
|
||||
,SHORTCUTS_Forest
|
||||
,SHORTCUTS_OtherCase
|
||||
,SHORTCUTS_Road
|
||||
,SHORTCUTS_TurnPenalization
|
||||
,SHORTCUTS_noBuildArea
|
||||
,SHORTCUTS_END
|
||||
|
||||
,ROADS_START
|
||||
,ROADS_BasePrice
|
||||
,ROADS_Coal
|
||||
,ROADS_Field
|
||||
,ROADS_Forest
|
||||
,ROADS_OtherCase
|
||||
,ROADS_Road
|
||||
,ROADS_TurnPenalization
|
||||
,ROADS_noBuildArea
|
||||
,ROADS_END
|
||||
);
|
||||
|
||||
|
||||
// Global constants for AI
|
||||
//const
|
||||
|
||||
// Global variables for AI
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
var
|
||||
{$ELSE}
|
||||
const
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
AI_Par: array[TAIPar] of Single = (
|
||||
0.0000000, // ATTACK_ArmyVectorField_START
|
||||
23.8595066, // ATTACK_ArmyVectorField_FindPositions_DistEnemyOffset
|
||||
17.4091473, // ATTACK_ArmyVectorField_FindPositions_DistEnemyOffsetFF
|
||||
1.5993488, // ATTACK_ArmyVectorField_FindPositions_DistEnemyGainFF
|
||||
16.9659538, // ATTACK_ArmyVectorField_FindPositions_DistCloseToEnemy
|
||||
6.5492649, // ATTACK_ArmyVectorField_FindPositions_DistMaxWalk
|
||||
15.9957075, // ATTACK_ArmyVectorField_FindPositions_FollowEnemyVectorFieldUth
|
||||
9.1061239, // ATTACK_ArmyVectorField_FindPositions_AvoidTraffic
|
||||
7.7757473, // ATTACK_ArmyVectorField_FindPositions_RallyPointOffset
|
||||
0.9000000, // ATTACK_ArmyVectorField_EvalClusters_InPlace
|
||||
2.1793294, // ATTACK_ArmyVectorField_EvalClusters_AtAdvantage
|
||||
0.0341255, // ATTACK_ArmyVectorField_EvalClusters_Ambushed
|
||||
0.5000000, // ATTACK_ArmyVectorField_DivideForces_DefendCityAdv
|
||||
0.1121276, // ATTACK_ArmyVectorField_DivideForces_SupportAllyAdv
|
||||
0.0000000, // ATTACK_ArmyVectorField_END
|
||||
|
||||
0.0000000, // ATTACK_SQUAD_START
|
||||
416.4127197, // ATTACK_SQUAD_ChangeTarget_Delay
|
||||
5.0000000, // ATTACK_SQUAD_MinWalkingDistance
|
||||
8.0000000, // ATTACK_SQUAD_TargetReached_House
|
||||
5.0000000, // ATTACK_SQUAD_TargetReached_Position
|
||||
10.2428083, // ATTACK_SQUAD_TargetReached_RangedSquad
|
||||
35.0000000, // ATTACK_SQUAD_TargetReached_Unit
|
||||
1.0000000, // ATTACK_SQUAD_TrafficDetection_Limit
|
||||
10.0000000, // ATTACK_SQUAD_TrafficDetection_Threshold
|
||||
0.0000000, // ATTACK_SQUAD_END
|
||||
|
||||
0.0000000, // ATTACK_SUPERVISOR_START
|
||||
22.1900902, // ATTACK_SUPERVISOR_EvalTarget_DistanceGroup
|
||||
3.9091630, // ATTACK_SUPERVISOR_EvalTarget_OpportunityDistGain
|
||||
3.3577795, // ATTACK_SUPERVISOR_EvalTarget_OpportunityGain
|
||||
0.6074438, // ATTACK_SUPERVISOR_EvalTarget_DecreaseRisk
|
||||
6.6606860, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainAntiHorse
|
||||
6.9580350, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainDist
|
||||
2.6582916, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainMelee
|
||||
3.9733243, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainMounted
|
||||
2.8656545, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainRangDist
|
||||
1.3565565, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainRanged
|
||||
0.0000000, // ATTACK_SUPERVISOR_END
|
||||
|
||||
0.0000000, // NAVMESH_PATHFINDING_START
|
||||
0.4070168, // NAVMESH_PATHFINDING_AvoidTraffic
|
||||
1.1412202, // NAVMESH_PATHFINDING_LineLength
|
||||
5.1420155, // NAVMESH_PATHFINDING_AvoidSpecEnemy
|
||||
0.0000000, // NAVMESH_PATHFINDING_END
|
||||
|
||||
0.0000000, // BUILDER_START
|
||||
1.6684477, // BUILDER_BuildHouse_FieldMaxWork
|
||||
11.6014986, // BUILDER_BuildHouse_RTPMaxWork
|
||||
21.6772480, // BUILDER_BuildHouse_RoadMaxWork
|
||||
8.1070709, // BUILDER_ChHTB_AllWorkerCoef
|
||||
21.3621922, // BUILDER_ChHTB_FractionCoef
|
||||
17.1468201, // BUILDER_ChHTB_FreeWorkerCoef
|
||||
0.2159205, // BUILDER_ChHTB_TrunkBalance
|
||||
11.5937538, // BUILDER_ChHTB_TrunkFactor
|
||||
10.0000000, // BUILDER_CreateShortcuts_MaxWork
|
||||
29.1807594, // BUILDER_Shortage_Gold
|
||||
11.7483110, // BUILDER_Shortage_Stone
|
||||
14.0460310, // BUILDER_Shortage_StoneReserve
|
||||
1.8335937, // BUILDER_Shortage_Trunk
|
||||
19.8352127, // BUILDER_Shortage_Wood
|
||||
0.0000000, // BUILDER_END
|
||||
|
||||
0.0000000, // EYE_GetForests_START
|
||||
26.4097462, // EYE_GetForests_MaxAB
|
||||
45.2892570, // EYE_GetForests_MinRndSoil
|
||||
2.9898586, // EYE_GetForests_MinTrees
|
||||
6.1196084, // EYE_GetForests_Radius
|
||||
165.0055695, // EYE_GetForests_SPRndOwnLimMax
|
||||
98.0682449, // EYE_GetForests_SPRndOwnLimMin
|
||||
0.0000000, // EYE_GetForests_END
|
||||
|
||||
0.0000000, // MANAGEMENT_START
|
||||
0.3049391, // MANAGEMENT_CheckUnitCount_SerfGoldCoef
|
||||
22.1768589, // MANAGEMENT_CheckUnitCount_SerfLimit1
|
||||
34.9827499, // MANAGEMENT_CheckUnitCount_SerfLimit2
|
||||
51.9892654, // MANAGEMENT_CheckUnitCount_SerfLimit3
|
||||
2.2670105, // MANAGEMENT_CheckUnitCount_WorkerGoldCoef
|
||||
6.1128011, // MANAGEMENT_GoldShortage
|
||||
0.0000000, // MANAGEMENT_END
|
||||
|
||||
0.0000000, // PLANNER_FARM_START
|
||||
13.7585087, // PLANNER_FARM_FieldCrit_FlatArea
|
||||
0.4989614, // PLANNER_FARM_FieldCrit_PolyRoute
|
||||
1.9767742, // PLANNER_FARM_FieldCrit_Soil
|
||||
5.6396270, // PLANNER_FARM_FindPlaceForHouse_CityCenter
|
||||
16.0000000, // PLANNER_FARM_FindPlaceForHouse_FlatArea
|
||||
19.9625053, // PLANNER_FARM_FindPlaceForHouse_HouseDist
|
||||
-1.1648518, // PLANNER_FARM_FindPlaceForHouse_Route
|
||||
759.2076416, // PLANNER_FARM_PlanFields_CanBuild
|
||||
32.8001213, // PLANNER_FARM_PlanFields_Dist
|
||||
95.6147385, // PLANNER_FARM_PlanFields_ExistField
|
||||
0.0000000, // PLANNER_FARM_END
|
||||
|
||||
0.0000000, // PLANNER_FindPlaceForHouse_START
|
||||
40.0904541, // PLANNER_FindPlaceForHouse_CityCenter
|
||||
2.7339566, // PLANNER_FindPlaceForHouse_FlatArea
|
||||
43.2200470, // PLANNER_FindPlaceForHouse_HouseDist
|
||||
2.4208529, // PLANNER_FindPlaceForHouse_Route
|
||||
25.1297512, // PLANNER_FindPlaceForHouse_SeedDist
|
||||
0.8601482, // PLANNER_FindPlaceForHouse_SnapCrit
|
||||
0.0000000, // PLANNER_FindPlaceForHouse_END
|
||||
|
||||
0.0000000, // PLANNER_FindPlaceForQuary_START
|
||||
27.4838066, // MANAGEMENT_CheckStoreWares_Stone
|
||||
0.6821785, // PREDICTOR_WareNeedPerAWorker_Stone
|
||||
14.5459347, // PREDICTOR_WareNeedPerAWorker_StoneOffset
|
||||
0.0047831, // PREDICTOR_WorkerCountCoef
|
||||
5.0048351, // PLANNER_FindPlaceForQuary_StoneLoc_StoneCnt
|
||||
125.4238663, // PLANNER_FindPlaceForQuary_StoneLoc_AlreadyMined
|
||||
13.8679466, // PLANNER_FindPlaceForQuary_StoneLoc_Distance
|
||||
20.9321098, // PLANNER_FindPlaceForQuary_DistCity
|
||||
25.5000973, // PLANNER_FindPlaceForQuary_DistStone
|
||||
3051.0822754, // PLANNER_FindPlaceForQuary_DistTimer
|
||||
90.0000000, // PLANNER_FindPlaceForQuary_Obstacle
|
||||
14.2139816, // PLANNER_FindPlaceForQuary_SnapCrit
|
||||
26.7360783, // PLANNER_FindPlaceForQuary_QtyStone
|
||||
0.0000000, // PLANNER_FindPlaceForQuary_END
|
||||
|
||||
0.0000000, // PLANNER_FOREST_START
|
||||
8.3981934, // PLANNER_FOREST_FindForestAround_MaxDist
|
||||
43.0639000, // PLANNER_FOREST_FindPlaceForWoodcutter_ABRange
|
||||
18.3647213, // PLANNER_FOREST_FindPlaceForWoodcutter_DistCrit
|
||||
6053.0366211, // PLANNER_FOREST_FindPlaceForWoodcutter_DistTimer
|
||||
359.9281311, // PLANNER_FOREST_FindPlaceForWoodcutter_ExistForest
|
||||
5.8913641, // PLANNER_FOREST_FindPlaceForWoodcutter_FlatArea
|
||||
4.6900163, // PLANNER_FOREST_FindPlaceForWoodcutter_FreeTiles
|
||||
3.5208817, // PLANNER_FOREST_FindPlaceForWoodcutter_Radius
|
||||
-0.6038398, // PLANNER_FOREST_FindPlaceForWoodcutter_Routes
|
||||
0.1276233, // PLANNER_FOREST_FindPlaceForWoodcutter_Soil
|
||||
7.2485070, // PLANNER_FOREST_FindPlaceForWoodcutter_TreeCnt
|
||||
21258.1250000, // PLANNER_FOREST_FindPlaceForWoodcutter_TreeCntTimer
|
||||
0.2943508, // PLANNER_FOREST_PlaceWoodcutter_DistFromForest
|
||||
0.0000000, // PLANNER_FOREST_END
|
||||
|
||||
0.0000000, // PLANNER_Snap_START
|
||||
293.8428345, // PLANNER_ObstaclesInHousePlan_Road
|
||||
599.5475464, // PLANNER_ObstaclesInHousePlan_Tree
|
||||
27.8181629, // PLANNER_SnapCrit_Field
|
||||
1.1461508, // PLANNER_SnapCrit_HouseOrRoad
|
||||
-9.2810154, // PLANNER_SnapCrit_NoBuild
|
||||
201.9597015, // PLANNER_SnapCrit_ObstacleInEntrance
|
||||
61.5381699, // PLANNER_SnapCrit_Road
|
||||
22.1572151, // PLANNER_SnapCrit_RoadInEntrance
|
||||
0.0000000, // PLANNER_Snap_END
|
||||
|
||||
0.0000000, // PREDICTOR_START
|
||||
44.3221283, // PREDICTOR_SecondSchool_MinRequiredUnits
|
||||
0.3007088, // PREDICTOR_WareNeedPerAWorker_Wood
|
||||
0.0000000, // PREDICTOR_END
|
||||
|
||||
0.0000000, // SHORTCUTS_START
|
||||
95.1310349, // SHORTCUTS_BasePrice
|
||||
49.1626778, // SHORTCUTS_Coal
|
||||
50.0000000, // SHORTCUTS_Field
|
||||
18.1300087, // SHORTCUTS_Forest
|
||||
24.3808022, // SHORTCUTS_OtherCase
|
||||
46.6517181, // SHORTCUTS_Road
|
||||
33.4370956, // SHORTCUTS_TurnPenalization
|
||||
25.7135334, // SHORTCUTS_noBuildArea
|
||||
0.0000000, // SHORTCUTS_END
|
||||
|
||||
0.0000000, // ROADS_START
|
||||
42.2091637, // ROADS_BasePrice
|
||||
29.0325890, // ROADS_Coal
|
||||
46.5412674, // ROADS_Field
|
||||
57.8719749, // ROADS_Forest
|
||||
11.6849775, // ROADS_OtherCase
|
||||
23.1054745, // ROADS_Road
|
||||
50.0000000, // ROADS_TurnPenalization
|
||||
35.9236031, // ROADS_noBuildArea
|
||||
0.0000000 // ROADS_END
|
||||
|
||||
);
|
||||
|
||||
|
||||
|
||||
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
const
|
||||
AI_Par_Offset: array[TAIPar] of Single = (
|
||||
0.00, // ATTACK_ArmyVectorField_START
|
||||
14.00, // ATTACK_ArmyVectorField_FindPositions_DistEnemyOffset
|
||||
12.00, // ATTACK_ArmyVectorField_FindPositions_DistEnemyOffsetFF
|
||||
1.00, // ATTACK_ArmyVectorField_FindPositions_DistEnemyGainFF
|
||||
12.00, // ATTACK_ArmyVectorField_FindPositions_DistCloseToEnemy
|
||||
1.00, // ATTACK_ArmyVectorField_FindPositions_DistMaxWalk
|
||||
5.00, // ATTACK_ArmyVectorField_FindPositions_FollowEnemyVectorFieldUth
|
||||
1.00, // ATTACK_ArmyVectorField_FindPositions_AvoidTraffic
|
||||
1.00, // ATTACK_ArmyVectorField_FindPositions_RallyPointOffset
|
||||
0.40, // ATTACK_ArmyVectorField_EvalClusters_InPlace
|
||||
0.00, // ATTACK_ArmyVectorField_EvalClusters_AtAdvantage
|
||||
0.00, // ATTACK_ArmyVectorField_EvalClusters_Ambushed
|
||||
0.50, // ATTACK_ArmyVectorField_DivideForces_DefendCityAdv
|
||||
0.00, // ATTACK_ArmyVectorField_DivideForces_SupportAllyAdv
|
||||
0.00, // ATTACK_ArmyVectorField_END
|
||||
|
||||
0.00, // ATTACK_SQUAD_START
|
||||
350.00, // ATTACK_SQUAD_ChangeTarget_Delay
|
||||
5.00, // ATTACK_SQUAD_MinWalkingDistance
|
||||
8.00, // ATTACK_SQUAD_TargetReached_House
|
||||
1.00, // ATTACK_SQUAD_TargetReached_Position
|
||||
9.00, // ATTACK_SQUAD_TargetReached_RangedSquad
|
||||
15.00, // ATTACK_SQUAD_TargetReached_Unit
|
||||
1.00, // ATTACK_SQUAD_TrafficDetection_Limit
|
||||
10.00, // ATTACK_SQUAD_TrafficDetection_Threshold
|
||||
0.00, // ATTACK_SQUAD_END
|
||||
|
||||
0.00, // ATTACK_SUPERVISOR_START
|
||||
10.00, // ATTACK_SUPERVISOR_EvalTarget_DistanceGroup
|
||||
1.00, // ATTACK_SUPERVISOR_EvalTarget_OpportunityDistGain
|
||||
1.00, // ATTACK_SUPERVISOR_EvalTarget_OpportunityGain
|
||||
0.50, // ATTACK_SUPERVISOR_EvalTarget_DecreaseRisk
|
||||
2.00, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainAntiHorse
|
||||
5.00, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainDist
|
||||
1.00, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainMelee
|
||||
1.00, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainMounted
|
||||
1.00, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainRangDist
|
||||
1.00, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainRanged
|
||||
0.00, // ATTACK_SUPERVISOR_END
|
||||
|
||||
0.00, // NAVMESH_PATHFINDING_START
|
||||
0.00, // NAVMESH_PATHFINDING_AvoidTraffic
|
||||
0.00, // NAVMESH_PATHFINDING_LineLength
|
||||
5.00, // NAVMESH_PATHFINDING_AvoidSpecEnemy
|
||||
0.00, // NAVMESH_PATHFINDING_END
|
||||
|
||||
0.00, // BUILDER_START
|
||||
1.00, // BUILDER_BuildHouse_FieldMaxWork
|
||||
1.00, // BUILDER_BuildHouse_RTPMaxWork
|
||||
5.00, // BUILDER_BuildHouse_RoadMaxWork
|
||||
8.00, // BUILDER_ChHTB_AllWorkerCoef
|
||||
5.00, // BUILDER_ChHTB_FractionCoef
|
||||
8.00, // BUILDER_ChHTB_FreeWorkerCoef
|
||||
0.00, // BUILDER_ChHTB_TrunkBalance
|
||||
8.00, // BUILDER_ChHTB_TrunkFactor
|
||||
1.00, // BUILDER_CreateShortcuts_MaxWork
|
||||
0.00, // BUILDER_Shortage_Gold
|
||||
10.00, // BUILDER_Shortage_Stone
|
||||
10.00, // BUILDER_Shortage_StoneReserve
|
||||
1.00, // BUILDER_Shortage_Trunk
|
||||
3.00, // BUILDER_Shortage_Wood
|
||||
0.00, // BUILDER_END
|
||||
|
||||
0.00, // EYE_GetForests_START
|
||||
1.00, // EYE_GetForests_MaxAB
|
||||
40.00, // EYE_GetForests_MinRndSoil
|
||||
1.00, // EYE_GetForests_MinTrees
|
||||
5.00, // EYE_GetForests_Radius
|
||||
100.00, // EYE_GetForests_SPRndOwnLimMax
|
||||
0.00, // EYE_GetForests_SPRndOwnLimMin
|
||||
0.00, // EYE_GetForests_END
|
||||
|
||||
0.00, // MANAGEMENT_START
|
||||
0.10, // MANAGEMENT_CheckUnitCount_SerfGoldCoef
|
||||
5.00, // MANAGEMENT_CheckUnitCount_SerfLimit1
|
||||
20.00, // MANAGEMENT_CheckUnitCount_SerfLimit2
|
||||
40.00, // MANAGEMENT_CheckUnitCount_SerfLimit3
|
||||
0.10, // MANAGEMENT_CheckUnitCount_WorkerGoldCoef
|
||||
1.00, // MANAGEMENT_GoldShortage
|
||||
0.00, // MANAGEMENT_END
|
||||
|
||||
0.00, // PLANNER_FARM_START
|
||||
10.00, // PLANNER_FARM_FieldCrit_FlatArea
|
||||
0.00, // PLANNER_FARM_FieldCrit_PolyRoute
|
||||
0.00, // PLANNER_FARM_FieldCrit_Soil
|
||||
0.00, // PLANNER_FARM_FindPlaceForHouse_CityCenter
|
||||
10.00, // PLANNER_FARM_FindPlaceForHouse_FlatArea
|
||||
5.00, // PLANNER_FARM_FindPlaceForHouse_HouseDist
|
||||
-2.00, // PLANNER_FARM_FindPlaceForHouse_Route
|
||||
500.00, // PLANNER_FARM_PlanFields_CanBuild
|
||||
0.00, // PLANNER_FARM_PlanFields_Dist
|
||||
30.00, // PLANNER_FARM_PlanFields_ExistField
|
||||
0.00, // PLANNER_FARM_END
|
||||
|
||||
0.00, // PLANNER_FindPlaceForHouse_START
|
||||
0.00, // PLANNER_FindPlaceForHouse_CityCenter
|
||||
0.00, // PLANNER_FindPlaceForHouse_FlatArea
|
||||
25.00, // PLANNER_FindPlaceForHouse_HouseDist
|
||||
0.00, // PLANNER_FindPlaceForHouse_Route
|
||||
0.00, // PLANNER_FindPlaceForHouse_SeedDist
|
||||
0.00, // PLANNER_FindPlaceForHouse_SnapCrit
|
||||
0.00, // PLANNER_FindPlaceForHouse_END
|
||||
|
||||
0.00, // PLANNER_FindPlaceForQuary_START
|
||||
0.00, // MANAGEMENT_CheckStoreWares_Stone
|
||||
0.50, // PREDICTOR_WareNeedPerAWorker_Stone
|
||||
10.00, // PREDICTOR_WareNeedPerAWorker_StoneOffset
|
||||
0.00, // PREDICTOR_WorkerCountCoef
|
||||
0.00, // PLANNER_FindPlaceForQuary_StoneLoc_StoneCnt
|
||||
100.00, // PLANNER_FindPlaceForQuary_StoneLoc_AlreadyMined
|
||||
0.00, // PLANNER_FindPlaceForQuary_StoneLoc_Distance
|
||||
0.00, // PLANNER_FindPlaceForQuary_DistCity
|
||||
0.00, // PLANNER_FindPlaceForQuary_DistStone
|
||||
0.00, // PLANNER_FindPlaceForQuary_DistTimer
|
||||
80.00, // PLANNER_FindPlaceForQuary_Obstacle
|
||||
5.00, // PLANNER_FindPlaceForQuary_SnapCrit
|
||||
0.00, // PLANNER_FindPlaceForQuary_QtyStone
|
||||
0.00, // PLANNER_FindPlaceForQuary_END
|
||||
|
||||
0.00, // PLANNER_FOREST_START
|
||||
5.00, // PLANNER_FOREST_FindForestAround_MaxDist
|
||||
0.00, // PLANNER_FOREST_FindPlaceForWoodcutter_ABRange
|
||||
8.00, // PLANNER_FOREST_FindPlaceForWoodcutter_DistCrit
|
||||
0.00, // PLANNER_FOREST_FindPlaceForWoodcutter_DistTimer
|
||||
0.00, // PLANNER_FOREST_FindPlaceForWoodcutter_ExistForest
|
||||
0.00, // PLANNER_FOREST_FindPlaceForWoodcutter_FlatArea
|
||||
0.00, // PLANNER_FOREST_FindPlaceForWoodcutter_FreeTiles
|
||||
3.00, // PLANNER_FOREST_FindPlaceForWoodcutter_Radius
|
||||
-1.00, // PLANNER_FOREST_FindPlaceForWoodcutter_Routes
|
||||
0.00, // PLANNER_FOREST_FindPlaceForWoodcutter_Soil
|
||||
0.00, // PLANNER_FOREST_FindPlaceForWoodcutter_TreeCnt
|
||||
12000.00, // PLANNER_FOREST_FindPlaceForWoodcutter_TreeCntTimer
|
||||
0.00, // PLANNER_FOREST_PlaceWoodcutter_DistFromForest
|
||||
0.00, // PLANNER_FOREST_END
|
||||
|
||||
0.00, // PLANNER_Snap_START
|
||||
200.00, // PLANNER_ObstaclesInHousePlan_Road
|
||||
500.00, // PLANNER_ObstaclesInHousePlan_Tree
|
||||
-20.00, // PLANNER_SnapCrit_Field
|
||||
-30.00, // PLANNER_SnapCrit_HouseOrRoad
|
||||
-30.00, // PLANNER_SnapCrit_NoBuild
|
||||
0.00, // PLANNER_SnapCrit_ObstacleInEntrance
|
||||
25.00, // PLANNER_SnapCrit_Road
|
||||
0.00, // PLANNER_SnapCrit_RoadInEntrance
|
||||
0.00, // PLANNER_Snap_END
|
||||
|
||||
0.00, // PREDICTOR_START
|
||||
20.00, // PREDICTOR_SecondSchool_MinRequiredUnits
|
||||
0.01, // PREDICTOR_WareNeedPerAWorker_Wood
|
||||
0.00, // PREDICTOR_END
|
||||
|
||||
0.00, // SHORTCUTS_START
|
||||
70.00, // SHORTCUTS_BasePrice
|
||||
20.00, // SHORTCUTS_Coal
|
||||
0.00, // SHORTCUTS_Field
|
||||
10.00, // SHORTCUTS_Forest
|
||||
0.00, // SHORTCUTS_OtherCase
|
||||
20.00, // SHORTCUTS_Road
|
||||
20.00, // SHORTCUTS_TurnPenalization
|
||||
20.00, // SHORTCUTS_noBuildArea
|
||||
0.00, // SHORTCUTS_END
|
||||
|
||||
0.00, // ROADS_START
|
||||
25.00, // ROADS_BasePrice
|
||||
0.00, // ROADS_Coal
|
||||
20.00, // ROADS_Field
|
||||
30.00, // ROADS_Forest
|
||||
0.00, // ROADS_OtherCase
|
||||
0.00, // ROADS_Road
|
||||
0.00, // ROADS_TurnPenalization
|
||||
15.00, // ROADS_noBuildArea
|
||||
0.00 // ROADS_END
|
||||
);
|
||||
|
||||
|
||||
AI_Par_Gain: array[TAIPar] of Single = (
|
||||
0.00, // ATTACK_ArmyVectorField_START
|
||||
10.00, // ATTACK_ArmyVectorField_FindPositions_DistEnemyOffset
|
||||
10.00, // ATTACK_ArmyVectorField_FindPositions_DistEnemyOffsetFF
|
||||
1.00, // ATTACK_ArmyVectorField_FindPositions_DistEnemyGainFF
|
||||
5.00, // ATTACK_ArmyVectorField_FindPositions_DistCloseToEnemy
|
||||
10.00, // ATTACK_ArmyVectorField_FindPositions_DistMaxWalk
|
||||
15.00, // ATTACK_ArmyVectorField_FindPositions_FollowEnemyVectorFieldUth
|
||||
9.00, // ATTACK_ArmyVectorField_FindPositions_AvoidTraffic
|
||||
10.00, // ATTACK_ArmyVectorField_FindPositions_RallyPointOffset
|
||||
0.50, // ATTACK_ArmyVectorField_EvalClusters_InPlace
|
||||
3.00, // ATTACK_ArmyVectorField_EvalClusters_AtAdvantage
|
||||
0.25, // ATTACK_ArmyVectorField_EvalClusters_Ambushed
|
||||
0.00, // ATTACK_ArmyVectorField_DivideForces_DefendCityAdv
|
||||
0.90, // ATTACK_ArmyVectorField_DivideForces_SupportAllyAdv
|
||||
0.00, // ATTACK_ArmyVectorField_END
|
||||
|
||||
0.00, // ATTACK_SQUAD_START
|
||||
100.00, // ATTACK_SQUAD_ChangeTarget_Delay
|
||||
0.00, // ATTACK_SQUAD_MinWalkingDistance
|
||||
0.00, // ATTACK_SQUAD_TargetReached_House
|
||||
4.00, // ATTACK_SQUAD_TargetReached_Position
|
||||
2.00, // ATTACK_SQUAD_TargetReached_RangedSquad
|
||||
20.00, // ATTACK_SQUAD_TargetReached_Unit
|
||||
0.00, // ATTACK_SQUAD_TrafficDetection_Limit
|
||||
0.00, // ATTACK_SQUAD_TrafficDetection_Threshold
|
||||
0.00, // ATTACK_SQUAD_END
|
||||
|
||||
0.00, // ATTACK_SUPERVISOR_START
|
||||
15.00, // ATTACK_SUPERVISOR_EvalTarget_DistanceGroup
|
||||
6.00, // ATTACK_SUPERVISOR_EvalTarget_OpportunityDistGain
|
||||
4.00, // ATTACK_SUPERVISOR_EvalTarget_OpportunityGain
|
||||
0.25, // ATTACK_SUPERVISOR_EvalTarget_DecreaseRisk
|
||||
5.00, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainAntiHorse
|
||||
10.00, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainDist
|
||||
3.00, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainMelee
|
||||
3.00, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainMounted
|
||||
3.00, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainRangDist
|
||||
3.00, // ATTACK_SUPERVISOR_EvalTarget_ThreatGainRanged
|
||||
0.00, // ATTACK_SUPERVISOR_END
|
||||
|
||||
0.00, // NAVMESH_PATHFINDING_START
|
||||
2.00, // NAVMESH_PATHFINDING_AvoidTraffic
|
||||
3.00, // NAVMESH_PATHFINDING_LineLength
|
||||
4.00, // NAVMESH_PATHFINDING_AvoidSpecEnemy
|
||||
0.00, // NAVMESH_PATHFINDING_END
|
||||
|
||||
0.00, // BUILDER_START
|
||||
1.00, // BUILDER_BuildHouse_FieldMaxWork
|
||||
15.00, // BUILDER_BuildHouse_RTPMaxWork
|
||||
20.00, // BUILDER_BuildHouse_RoadMaxWork
|
||||
10.00, // BUILDER_ChHTB_AllWorkerCoef
|
||||
40.00, // BUILDER_ChHTB_FractionCoef
|
||||
20.00, // BUILDER_ChHTB_FreeWorkerCoef
|
||||
3.00, // BUILDER_ChHTB_TrunkBalance
|
||||
12.00, // BUILDER_ChHTB_TrunkFactor
|
||||
9.00, // BUILDER_CreateShortcuts_MaxWork
|
||||
35.00, // BUILDER_Shortage_Gold
|
||||
15.00, // BUILDER_Shortage_Stone
|
||||
40.00, // BUILDER_Shortage_StoneReserve
|
||||
3.00, // BUILDER_Shortage_Trunk
|
||||
20.00, // BUILDER_Shortage_Wood
|
||||
0.00, // BUILDER_END
|
||||
|
||||
0.00, // EYE_GetForests_START
|
||||
200.00, // EYE_GetForests_MaxAB
|
||||
22.00, // EYE_GetForests_MinRndSoil
|
||||
4.00, // EYE_GetForests_MinTrees
|
||||
4.00, // EYE_GetForests_Radius
|
||||
155.00, // EYE_GetForests_SPRndOwnLimMax
|
||||
155.00, // EYE_GetForests_SPRndOwnLimMin
|
||||
0.00, // EYE_GetForests_END
|
||||
|
||||
0.00, // MANAGEMENT_START
|
||||
3.00, // MANAGEMENT_CheckUnitCount_SerfGoldCoef
|
||||
20.00, // MANAGEMENT_CheckUnitCount_SerfLimit1
|
||||
20.00, // MANAGEMENT_CheckUnitCount_SerfLimit2
|
||||
30.00, // MANAGEMENT_CheckUnitCount_SerfLimit3
|
||||
3.00, // MANAGEMENT_CheckUnitCount_WorkerGoldCoef
|
||||
15.00, // MANAGEMENT_GoldShortage
|
||||
0.00, // MANAGEMENT_END
|
||||
|
||||
0.00, // PLANNER_FARM_START
|
||||
10.00, // PLANNER_FARM_FieldCrit_FlatArea
|
||||
5.00, // PLANNER_FARM_FieldCrit_PolyRoute
|
||||
3.00, // PLANNER_FARM_FieldCrit_Soil
|
||||
10.00, // PLANNER_FARM_FindPlaceForHouse_CityCenter
|
||||
10.00, // PLANNER_FARM_FindPlaceForHouse_FlatArea
|
||||
15.00, // PLANNER_FARM_FindPlaceForHouse_HouseDist
|
||||
4.00, // PLANNER_FARM_FindPlaceForHouse_Route
|
||||
500.00, // PLANNER_FARM_PlanFields_CanBuild
|
||||
75.00, // PLANNER_FARM_PlanFields_Dist
|
||||
75.00, // PLANNER_FARM_PlanFields_ExistField
|
||||
0.00, // PLANNER_FARM_END
|
||||
|
||||
0.00, // PLANNER_FindPlaceForHouse_START
|
||||
80.00, // PLANNER_FindPlaceForHouse_CityCenter
|
||||
6.00, // PLANNER_FindPlaceForHouse_FlatArea
|
||||
20.00, // PLANNER_FindPlaceForHouse_HouseDist
|
||||
4.00, // PLANNER_FindPlaceForHouse_Route
|
||||
50.00, // PLANNER_FindPlaceForHouse_SeedDist
|
||||
3.00, // PLANNER_FindPlaceForHouse_SnapCrit
|
||||
0.00, // PLANNER_FindPlaceForHouse_END
|
||||
|
||||
0.00, // PLANNER_FindPlaceForQuary_START
|
||||
50.00, // MANAGEMENT_CheckStoreWares_Stone
|
||||
0.30, // PREDICTOR_WareNeedPerAWorker_Stone
|
||||
10.00, // PREDICTOR_WareNeedPerAWorker_StoneOffset
|
||||
0.01, // PREDICTOR_WorkerCountCoef
|
||||
10.00, // PLANNER_FindPlaceForQuary_StoneLoc_StoneCnt
|
||||
100.00, // PLANNER_FindPlaceForQuary_StoneLoc_AlreadyMined
|
||||
20.00, // PLANNER_FindPlaceForQuary_StoneLoc_Distance
|
||||
50.00, // PLANNER_FindPlaceForQuary_DistCity
|
||||
50.00, // PLANNER_FindPlaceForQuary_DistStone
|
||||
15000.00, // PLANNER_FindPlaceForQuary_DistTimer
|
||||
50.00, // PLANNER_FindPlaceForQuary_Obstacle
|
||||
20.00, // PLANNER_FindPlaceForQuary_SnapCrit
|
||||
50.00, // PLANNER_FindPlaceForQuary_QtyStone
|
||||
0.00, // PLANNER_FindPlaceForQuary_END
|
||||
|
||||
0.00, // PLANNER_FOREST_START
|
||||
5.00, // PLANNER_FOREST_FindForestAround_MaxDist
|
||||
150.00, // PLANNER_FOREST_FindPlaceForWoodcutter_ABRange
|
||||
20.00, // PLANNER_FOREST_FindPlaceForWoodcutter_DistCrit
|
||||
10000.00, // PLANNER_FOREST_FindPlaceForWoodcutter_DistTimer
|
||||
500.00, // PLANNER_FOREST_FindPlaceForWoodcutter_ExistForest
|
||||
6.00, // PLANNER_FOREST_FindPlaceForWoodcutter_FlatArea
|
||||
6.00, // PLANNER_FOREST_FindPlaceForWoodcutter_FreeTiles
|
||||
4.00, // PLANNER_FOREST_FindPlaceForWoodcutter_Radius
|
||||
2.00, // PLANNER_FOREST_FindPlaceForWoodcutter_Routes
|
||||
3.00, // PLANNER_FOREST_FindPlaceForWoodcutter_Soil
|
||||
21.00, // PLANNER_FOREST_FindPlaceForWoodcutter_TreeCnt
|
||||
12000.00, // PLANNER_FOREST_FindPlaceForWoodcutter_TreeCntTimer
|
||||
2.00, // PLANNER_FOREST_PlaceWoodcutter_DistFromForest
|
||||
0.00, // PLANNER_FOREST_END
|
||||
|
||||
0.00, // PLANNER_Snap_START
|
||||
500.00, // PLANNER_ObstaclesInHousePlan_Road
|
||||
1000.00, // PLANNER_ObstaclesInHousePlan_Tree
|
||||
50.00, // PLANNER_SnapCrit_Field
|
||||
50.00, // PLANNER_SnapCrit_HouseOrRoad
|
||||
50.00, // PLANNER_SnapCrit_NoBuild
|
||||
1000.00, // PLANNER_SnapCrit_ObstacleInEntrance
|
||||
50.00, // PLANNER_SnapCrit_Road
|
||||
300.00, // PLANNER_SnapCrit_RoadInEntrance
|
||||
0.00, // PLANNER_Snap_END
|
||||
|
||||
0.00, // PREDICTOR_START
|
||||
30.00, // PREDICTOR_SecondSchool_MinRequiredUnits
|
||||
0.30, // PREDICTOR_WareNeedPerAWorker_Wood
|
||||
0.00, // PREDICTOR_END
|
||||
|
||||
0.00, // SHORTCUTS_START
|
||||
40.00, // SHORTCUTS_BasePrice
|
||||
50.00, // SHORTCUTS_Coal
|
||||
50.00, // SHORTCUTS_Field
|
||||
40.00, // SHORTCUTS_Forest
|
||||
50.00, // SHORTCUTS_OtherCase
|
||||
50.00, // SHORTCUTS_Road
|
||||
50.00, // SHORTCUTS_TurnPenalization
|
||||
50.00, // SHORTCUTS_noBuildArea
|
||||
0.00, // SHORTCUTS_END
|
||||
|
||||
0.00, // ROADS_START
|
||||
30.00, // ROADS_BasePrice
|
||||
50.00, // ROADS_Coal
|
||||
40.00, // ROADS_Field
|
||||
50.00, // ROADS_Forest
|
||||
50.00, // ROADS_OtherCase
|
||||
50.00, // ROADS_Road
|
||||
50.00, // ROADS_TurnPenalization
|
||||
35.00, // ROADS_noBuildArea
|
||||
0.00 // ROADS_END
|
||||
);
|
||||
{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
{$IFDEF PARALLEL_RUNNER}
|
||||
procedure LoadGAParameters(LoadStream: TKMemoryStream);
|
||||
begin
|
||||
LoadStream.CheckMarker('LoadGAParameters');
|
||||
LoadStream.Read(AI_Par,SizeOf(AI_Par));
|
||||
end;
|
||||
|
||||
procedure SaveGAParameters(SaveStream: TKMemoryStream);
|
||||
begin
|
||||
SaveStream.PlaceMarker('LoadGAParameters');
|
||||
SaveStream.Write(AI_Par,SizeOf(AI_Par));
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
end.
|
||||
+1784
File diff suppressed because it is too large.
Load diff
+921
@@ -0,0 +1,921 @@
|
||||
{
|
||||
Artificial intelligence
|
||||
@author: Martin Toupal
|
||||
@e-mail: poznamenany@gmail.com
|
||||
}
|
||||
unit KM_ArmyAttackNew;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Generics.Collections, Classes, KromUtils, Math, SysUtils,
|
||||
KM_Units, KM_UnitGroup,
|
||||
KM_CommonClasses, KM_Defaults, KM_Points,
|
||||
KM_Houses, KM_ResHouses, KM_NavMeshPathFinding,
|
||||
KM_ResTypes;
|
||||
|
||||
type
|
||||
TKMTargetType = (ttNone, ttPoint, ttHouse, ttGroup, ttUnit);
|
||||
TKMCombatPhase = (cpIdle, cpWalk, cpAttack, cpDead);
|
||||
TKMStuckInTraffic = record
|
||||
StuckInTraffic: Boolean;
|
||||
StuckCounter: Byte;
|
||||
PreviousPosition: TKMPoint;
|
||||
end;
|
||||
TKMCombatGroup = class;
|
||||
TKMCombatGroupArray = array of TKMCombatGroup;
|
||||
|
||||
TKMCombatGroup = class
|
||||
fGroup: TKMUnitGroup;
|
||||
fTargetType: TKMTargetType;
|
||||
fCombatPhase: TKMCombatPhase;
|
||||
fOnPlace, fTargetChanged: Boolean;
|
||||
fTrafficDetection: TKMStuckInTraffic;
|
||||
fTargetGroup: TKMUnitGroup;
|
||||
fTargetUnit: TKMUnit;
|
||||
fTargetHouse: TKMHouse;
|
||||
fTargetPosition: TKMPointDir;
|
||||
fTargetAim: TKMPoint;
|
||||
fWalkTimeLimit, fAttackTimeLimit: Cardinal;
|
||||
|
||||
function SquadInFight(): Boolean; inline;
|
||||
function GetGroupPosition(): TKMPoint; inline;
|
||||
function PlanPath(aTick: Cardinal; var aActualPosition, aTargetPosition: TKMPoint; aOrderAttack: Boolean = False; aOrderDestroy: Boolean = False): Boolean;
|
||||
|
||||
procedure SetTargetGroup(aGroup: TKMUnitGroup);
|
||||
procedure SetTargetUnit(aUnit: TKMUnit);
|
||||
procedure ChangeTargetUnit(aUnit: TKMUnit);
|
||||
procedure SetTargetHouse(aHouse: TKMHouse);
|
||||
procedure SetTargetPosition(aLoc: TKMPointDir);
|
||||
|
||||
public
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
DEBUGPointPath: TKMPointArray;
|
||||
{$ENDIF}
|
||||
constructor Create(aGroup: TKMUnitGroup);
|
||||
constructor Load(LoadStream: TKMemoryStream);
|
||||
destructor Destroy; override;
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure SyncLoad();
|
||||
|
||||
property Group: TKMUnitGroup read fGroup;
|
||||
property TargetType: TKMTargetType read fTargetType;
|
||||
property CombatPhase: TKMCombatPhase read fCombatPhase;
|
||||
property OnPlace: Boolean read fOnPlace;
|
||||
property InFight: Boolean read SquadInFight;
|
||||
property Position: TKMPoint read GetGroupPosition;
|
||||
property StuckInTraffic: Boolean read fTrafficDetection.StuckInTraffic;
|
||||
property WalkTimeLimit: Cardinal read fWalkTimeLimit write fWalkTimeLimit;
|
||||
property AttackTimeLimit: Cardinal read fAttackTimeLimit write fAttackTimeLimit;
|
||||
property TargetGroup: TKMUnitGroup read fTargetGroup write SetTargetGroup;
|
||||
property TargetUnit: TKMUnit read fTargetUnit write SetTargetUnit;
|
||||
property TargetHouse: TKMHouse read fTargetHouse write SetTargetHouse;
|
||||
property TargetPosition: TKMPointDir read fTargetPosition write SetTargetPosition;
|
||||
property TargetAim: TKMPoint read fTargetAim;
|
||||
|
||||
procedure UpdateState(aTick: Cardinal);
|
||||
end;
|
||||
|
||||
TKMArmyAttackNew = class
|
||||
private
|
||||
fOwner: TKMHandID;
|
||||
fCombatGroups: TObjectList<TKMCombatGroup>;
|
||||
|
||||
function GetCount(): Integer;
|
||||
function GetCombatGroupIdx(aGroup: TKMUnitGroup): Integer;
|
||||
function GetCombatGroup(aGroup: TKMUnitGroup): TKMCombatGroup;
|
||||
public
|
||||
constructor Create(aOwner: TKMHandID);
|
||||
destructor Destroy(); override;
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure Load(LoadStream: TKMemoryStream);
|
||||
procedure SyncLoad();
|
||||
|
||||
property CG: TObjectList<TKMCombatGroup> read fCombatGroups;
|
||||
property Count: Integer read GetCount;
|
||||
property CombatGroup[aGroup: TKMUnitGroup]: TKMCombatGroup read GetCombatGroup;
|
||||
|
||||
procedure AfterMissionInit();
|
||||
procedure UpdateState(aTick: Cardinal);
|
||||
procedure OwnerUpdate(aPlayer: TKMHandID);
|
||||
|
||||
function IsGroupInAction(aGroup: TKMUnitGroup): Boolean;
|
||||
|
||||
function AddGroup(const aGroup: TKMUnitGroup): TKMCombatGroup;
|
||||
procedure AddGroups(const aGroups: TKMUnitGroupArray);
|
||||
procedure ReleaseGroup(aGroup: TKMUnitGroup);
|
||||
procedure ReleaseGroups();
|
||||
procedure LinkGroup(aGroup: TKMUnitGroup);
|
||||
|
||||
procedure LogStatus(var aBalanceText: UnicodeString);
|
||||
procedure Paint();
|
||||
end;
|
||||
|
||||
const
|
||||
// Houses in TARGET_HOUSES will be selected as a primary target (so the company will come to this point but it will not attack it because of this list)
|
||||
TARGET_HOUSES: TKMHouseTypeSet = [htBarracks, htStore, htSchool, htTownhall];
|
||||
// Houses in SCAN_HOUSES will be destroyed when they are in radius (it should also contain TARGET_HOUSES)
|
||||
SCAN_HOUSES: TKMHouseTypeSet = [htWatchTower, htBarracks, htStore, htSchool, htTownhall];
|
||||
// All houses for final stage of attack algorithm
|
||||
ALL_HOUSES: TKMHouseTypeSet = HOUSES_VALID;
|
||||
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
var
|
||||
gTimePathfinding, gTimeAiming: Int64;
|
||||
{$ENDIF}
|
||||
|
||||
implementation
|
||||
uses
|
||||
Types, TypInfo,
|
||||
KM_Entity,
|
||||
KM_Game, KM_GameParams,
|
||||
KM_HandsCollection, KM_HandTypes, KM_HandEntity,
|
||||
KM_Terrain, KM_AIFields,
|
||||
KM_NavMesh, KM_RenderAux,
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
KM_CommonUtils,
|
||||
{$ENDIF}
|
||||
KM_UnitWarrior, KM_AIParameters, KM_UnitActionFight, KM_UnitActionWalkTo,
|
||||
KM_UnitGroupTypes;
|
||||
|
||||
|
||||
{ TKMCombatGroup }
|
||||
constructor TKMCombatGroup.Create(aGroup: TKMUnitGroup);
|
||||
begin
|
||||
inherited Create;
|
||||
fTargetType := ttPoint;
|
||||
fCombatPhase := cpIdle;
|
||||
fOnPlace := False;
|
||||
fTargetChanged := True;
|
||||
fTrafficDetection.StuckInTraffic := False;
|
||||
fTrafficDetection.PreviousPosition := aGroup.Position;
|
||||
fTrafficDetection.StuckCounter := 0;
|
||||
fTargetPosition := KMPointDir(KMPOINT_ZERO, dirNA);
|
||||
fTargetAim := KMPOINT_ZERO;
|
||||
fWalkTimeLimit := 0;
|
||||
fAttackTimeLimit := 0;
|
||||
fGroup := aGroup.GetPointer();
|
||||
fTargetGroup := nil;
|
||||
fTargetUnit := nil;
|
||||
fTargetHouse := nil;
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMCombatGroup.Destroy();
|
||||
begin
|
||||
gHands.CleanUpGroupPointer(fGroup);
|
||||
gHands.CleanUpGroupPointer(fTargetGroup);
|
||||
gHands.CleanUpUnitPointer(fTargetUnit);
|
||||
gHands.CleanUpHousePointer(fTargetHouse);
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
constructor TKMCombatGroup.Load(LoadStream: TKMemoryStream);
|
||||
begin
|
||||
inherited Create;
|
||||
LoadStream.CheckMarker('CombatGroup');
|
||||
LoadStream.Read(fTargetType, SizeOf(fTargetType));
|
||||
LoadStream.Read(fCombatPhase, SizeOf(fCombatPhase));
|
||||
LoadStream.Read(fOnPlace);
|
||||
LoadStream.Read(fTargetChanged);
|
||||
LoadStream.Read(fTargetPosition);
|
||||
LoadStream.Read(fTargetAim, SizeOf(fTargetAim));
|
||||
LoadStream.Read(fWalkTimeLimit, SizeOf(fWalkTimeLimit));
|
||||
LoadStream.Read(fAttackTimeLimit, SizeOf(fAttackTimeLimit));
|
||||
LoadStream.Read(fTrafficDetection, SizeOf(TKMStuckInTraffic));
|
||||
//Subst on syncload
|
||||
LoadStream.Read(fGroup, 4);
|
||||
LoadStream.Read(fTargetGroup, 4);
|
||||
LoadStream.Read(fTargetUnit, 4);
|
||||
LoadStream.Read(fTargetHouse, 4);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCombatGroup.Save(SaveStream: TKMemoryStream);
|
||||
begin
|
||||
SaveStream.PlaceMarker('CombatGroup');
|
||||
SaveStream.Write(fTargetType, SizeOf(fTargetType));
|
||||
SaveStream.Write(fCombatPhase, SizeOf(fCombatPhase));
|
||||
SaveStream.Write(fOnPlace);
|
||||
SaveStream.Write(fTargetChanged);
|
||||
SaveStream.Write(fTargetPosition);
|
||||
SaveStream.Write(fTargetAim, SizeOf(fTargetAim));
|
||||
SaveStream.Write(fWalkTimeLimit, SizeOf(fWalkTimeLimit));
|
||||
SaveStream.Write(fAttackTimeLimit, SizeOf(fAttackTimeLimit));
|
||||
SaveStream.Write(fTrafficDetection, SizeOf(TKMStuckInTraffic));
|
||||
SaveStream.Write(fGroup.UID);
|
||||
SaveStream.Write(fTargetGroup.UID);
|
||||
SaveStream.Write(fTargetUnit.UID);
|
||||
SaveStream.Write(fTargetHouse.UID);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCombatGroup.SyncLoad();
|
||||
begin
|
||||
fGroup := gHands.GetGroupByUID(Integer(fGroup));
|
||||
fTargetHouse := gHands.GetHouseByUID(Integer(fTargetHouse));
|
||||
fTargetGroup := gHands.GetGroupByUID(Integer(fTargetGroup));
|
||||
fTargetUnit := gHands.GetUnitByUID(Integer(fTargetUnit));
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCombatGroup.SetTargetGroup(aGroup: TKMUnitGroup);
|
||||
begin
|
||||
// Check old target
|
||||
if (aGroup = fTargetGroup) then
|
||||
Exit;
|
||||
// Clear pointer
|
||||
gHands.CleanUpGroupPointer(fTargetGroup);
|
||||
// Update target
|
||||
if (aGroup = nil) OR aGroup.IsDead then
|
||||
SetTargetUnit(nil)
|
||||
else
|
||||
begin
|
||||
fTargetGroup := aGroup.GetPointer;
|
||||
ChangeTargetUnit( aGroup.GetAliveMember() );
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCombatGroup.SetTargetUnit(aUnit: TKMUnit);
|
||||
begin
|
||||
// Check old target
|
||||
if (fTargetUnit = aUnit) then
|
||||
Exit;
|
||||
// Remove group pointer
|
||||
gHands.CleanUpGroupPointer(fTargetGroup);
|
||||
// Archers will reaim (+ reset animation) only in case that new target is in specific distance from existing target
|
||||
if (aUnit <> nil) AND not aUnit.IsDeadOrDying then
|
||||
ChangeTargetUnit(aUnit)
|
||||
else
|
||||
gHands.CleanUpUnitPointer(fTargetUnit);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCombatGroup.ChangeTargetUnit(aUnit: TKMUnit);
|
||||
begin
|
||||
fTargetChanged := (fTargetUnit = nil) OR not fTargetUnit.IsDeadOrDying
|
||||
OR ((aUnit is TKMUnitWarrior) AND (fTargetUnit is TKMUnitWarrior) AND (TKMUnitWarrior(fTargetUnit).Group <> TKMUnitWarrior(aUnit).Group));
|
||||
gHands.CleanUpUnitPointer(fTargetUnit);
|
||||
fTargetUnit := aUnit.GetPointer;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCombatGroup.SetTargetHouse(aHouse: TKMHouse);
|
||||
begin
|
||||
// House have lower priority so if there is request for attacking house, then target group and unit must be nil
|
||||
if (aHouse <> nil) AND not aHouse.IsDestroyed then
|
||||
SetTargetGroup(nil); // Includes also nil of target unit
|
||||
// Check old target
|
||||
if (fTargetHouse = aHouse) then
|
||||
Exit;
|
||||
// Clean pointer
|
||||
gHands.CleanUpHousePointer(fTargetHouse);
|
||||
// Update target
|
||||
fTargetChanged := True;
|
||||
if (aHouse <> nil) then
|
||||
fTargetHouse := aHouse.GetPointer;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCombatGroup.SetTargetPosition(aLoc: TKMPointDir);
|
||||
begin
|
||||
SetTargetGroup(nil);
|
||||
SetTargetHouse(nil);
|
||||
fTargetPosition := aLoc;
|
||||
fWalkTimeLimit := gGameParams.Tick + KMDistanceAbs(fTargetPosition.Loc, Position) * 5;
|
||||
end;
|
||||
|
||||
|
||||
function TKMCombatGroup.SquadInFight(): Boolean;
|
||||
begin
|
||||
Result := not fGroup.CanTakePlayerOrders;
|
||||
end;
|
||||
|
||||
|
||||
function TKMCombatGroup.GetGroupPosition(): TKMPoint;
|
||||
begin
|
||||
Result := fGroup.Position;
|
||||
end;
|
||||
|
||||
|
||||
// Update state of squad (group orders)
|
||||
procedure TKMCombatGroup.UpdateState(aTick: Cardinal);
|
||||
|
||||
function GetTargetUnitPosition(): TKMPoint;
|
||||
var
|
||||
K: Integer;
|
||||
Dist, BestDist: Single;
|
||||
BestTgt: TKMUnit;
|
||||
G: TKMUnitGroup;
|
||||
begin
|
||||
Result := fTargetUnit.Position;
|
||||
// Get closest warrior in enemy group if the squad is ranged
|
||||
if (fGroup.GroupType = gtRanged) AND (fTargetUnit is TKMUnitWarrior) then
|
||||
begin
|
||||
BestTgt := nil;
|
||||
G := TKMUnitWarrior(fTargetUnit).Group;
|
||||
//Group will be nil if we target a warrior still walking out of barracks
|
||||
if G <> nil then
|
||||
begin
|
||||
BestDist := 1E10;
|
||||
for K := 0 to G.Count - 1 do
|
||||
if not G.Members[K].IsDeadOrDying then
|
||||
begin
|
||||
Dist := KMDistanceSqr(fGroup.Position,G.Members[K].Position);
|
||||
if (Dist < BestDist) then
|
||||
begin
|
||||
BestTgt := G.Members[K];
|
||||
BestDist := Dist;
|
||||
end;
|
||||
end;
|
||||
if (BestTgt <> nil) then
|
||||
begin
|
||||
gHands.CleanUpUnitPointer(fTargetUnit);
|
||||
fTargetUnit := BestTgt.GetPointer;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure MoveRangedInFormation();
|
||||
var
|
||||
K, CntFighting, CntWalking, CntCanFight: Integer;
|
||||
NodeList: TKMPointList;
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
Timer: Int64;
|
||||
{$ENDIF}
|
||||
begin
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
Timer := TimeGetUsec();
|
||||
{$ENDIF}
|
||||
// Target comes from behind
|
||||
K := Abs(Byte(KMGetDirection(Position,TargetAim)) - Byte(Group.OrderLoc.Dir));
|
||||
if (K > 1) AND (K < 7) then
|
||||
begin
|
||||
Group.OrderAttackUnit(fTargetUnit, True);
|
||||
Exit;
|
||||
end;
|
||||
//if Group.GetAliveMember.WithinFightRange(fTargetAim) then
|
||||
// Check amount of shooting members
|
||||
CntFighting := 0;
|
||||
CntWalking := 0;
|
||||
CntCanFight := 0;
|
||||
for K := 0 to Group.Count - 1 do
|
||||
begin
|
||||
CntFighting := CntFighting + Byte(Group.Members[K].Action is TKMUnitActionFight);
|
||||
CntWalking := CntWalking + Byte(Group.Members[K].Action is TKMUnitActionWalkTo);
|
||||
CntCanFight := CntCanFight + Byte(Group.Members[K].WithinFightRange(fTargetAim));
|
||||
end;
|
||||
if (CntFighting = 0) AND (CntCanFight > 0) then
|
||||
begin
|
||||
Group.OrderAttackUnit(fTargetUnit, True);
|
||||
Exit;
|
||||
end;
|
||||
if (CntFighting > Group.Count * 0.7) OR (CntCanFight > Group.Count * 0.5) OR (CntWalking + CntFighting > Group.Count * 0.7) then
|
||||
Exit;
|
||||
NodeList := TKMPointList.Create;
|
||||
try
|
||||
if gGame.Pathfinding.Route_Make(Group.GetAliveMember.Position, TargetUnit.PositionNext, [tpWalk], Group.GetAliveMember.GetFightMaxRange, nil, NodeList) then
|
||||
begin
|
||||
fTargetPosition := KMPointDir(NodeList[NodeList.Count-1],KMGetDirection(NodeList[NodeList.Count-1], TargetUnit.PositionNext));
|
||||
if KMSamePoint(fTargetPosition.Loc, Position) then
|
||||
fTargetPosition.Loc := KMGetPointInDir(fTargetPosition.Loc, fTargetPosition.Dir, 1);
|
||||
Group.OrderWalk(fTargetPosition.Loc, True, wtokAISquad, fTargetPosition.Dir);
|
||||
end;
|
||||
finally
|
||||
NodeList.Free;
|
||||
end;
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
gTimeAiming := gTimeAiming + TimeGetUsec() - Timer;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
var
|
||||
walkedDistance: Integer;
|
||||
ActPos: TKMPoint;
|
||||
begin
|
||||
fOnPlace := False;
|
||||
// Check group status and possibility to give order
|
||||
if (fGroup = nil) OR fGroup.IsDead then
|
||||
fCombatPhase := cpDead;
|
||||
if (fCombatPhase = cpDead) OR InFight then
|
||||
Exit;
|
||||
|
||||
// Check targets
|
||||
if (fTargetGroup <> nil) AND fTargetGroup.IsDead then
|
||||
SetTargetGroup(nil);
|
||||
if (fTargetUnit <> nil) AND fTargetUnit.IsDeadOrDying then
|
||||
begin
|
||||
if (fTargetGroup <> nil) then
|
||||
begin
|
||||
ChangeTargetUnit( fTargetGroup.GetAliveMember() );
|
||||
fTargetAim := GetTargetUnitPosition();
|
||||
// New target is out of range -> wait for supervisor to update target group to the closest
|
||||
if KMDistanceSqr(fTargetAim,Position) > Sqr(Group.GetAliveMember.GetFightMaxRange) then
|
||||
begin
|
||||
fTargetType := ttGroup;
|
||||
fCombatPhase := cpAttack;
|
||||
Exit;
|
||||
end;
|
||||
end
|
||||
else
|
||||
SetTargetUnit(nil);
|
||||
end;
|
||||
if (fTargetHouse <> nil) AND (fTargetHouse.IsDestroyed) then
|
||||
SetTargetHouse(nil);
|
||||
|
||||
// Orders
|
||||
ActPos := Position;
|
||||
if (fTargetUnit <> nil) OR (fTargetGroup <> nil) then
|
||||
begin
|
||||
fTargetAim := GetTargetUnitPosition();
|
||||
if PlanPath(aTick, ActPos, fTargetAim, True, False) then // Check if squad is in the place
|
||||
Group.OrderWalk(fTargetAim, True, wtokAISquad, TargetPosition.Dir)
|
||||
else if (fGroup.GroupType = gtRanged) then
|
||||
MoveRangedInFormation()
|
||||
else if
|
||||
fTargetChanged // Target has been changed
|
||||
OR (KMDistanceSqr(fTargetAim,ActPos) > 12*12)
|
||||
OR (fGroup.Order in [goNone, goAttackHouse, goWalkTo]) // Force Group to change its task
|
||||
OR (fAttackTimeLimit < aTick) // Make sure that unit is not stuck
|
||||
then
|
||||
begin
|
||||
fAttackTimeLimit := aTick + Round(AI_Par[ATTACK_SQUAD_ChangeTarget_Delay]);
|
||||
fTargetChanged := False;
|
||||
Group.OrderAttackUnit(fTargetUnit, True);
|
||||
end;
|
||||
fOnPlace := True;
|
||||
end
|
||||
else if (fTargetHouse <> nil) then
|
||||
begin
|
||||
fTargetAim := fTargetHouse.Position;
|
||||
if PlanPath(aTick, ActPos, fTargetAim, False, True) then
|
||||
Group.OrderWalk(fTargetAim, True, wtokAISquad, TargetPosition.Dir)
|
||||
else if (fGroup.GroupType <> gtRanged) OR fTargetChanged OR (fAttackTimeLimit < aTick) then
|
||||
begin
|
||||
fAttackTimeLimit := aTick + Round(AI_Par[ATTACK_SQUAD_ChangeTarget_Delay]);
|
||||
fTargetChanged := False;
|
||||
Group.OrderAttackHouse(fTargetHouse, True);
|
||||
end;
|
||||
fOnPlace := True;
|
||||
end
|
||||
else if not KMSamePoint(TargetPosition.Loc, KMPOINT_ZERO) then
|
||||
begin
|
||||
fTargetAim := TargetPosition.Loc;
|
||||
if PlanPath(aTick, ActPos, fTargetAim, False, False) then
|
||||
Group.OrderWalk(fTargetAim, True, wtokAISquad, TargetPosition.Dir)
|
||||
else if not KMSamePoint(Group.Position, TargetPosition.Loc) then // Dont repeat order and let archers fire
|
||||
Group.OrderWalk(TargetPosition.Loc, True, wtokAISquad, TargetPosition.Dir);
|
||||
end
|
||||
else
|
||||
Group.OrderNone();
|
||||
|
||||
fTargetType := ttNone;
|
||||
fCombatPhase := cpAttack;
|
||||
if (fTargetHouse <> nil) then fTargetType := ttHouse
|
||||
else if (fTargetGroup <> nil) then fTargetType := ttGroup
|
||||
else if (fTargetUnit <> nil) then fTargetType := ttUnit
|
||||
else if not KMSamePoint(fTargetPosition.Loc, KMPOINT_ZERO) then
|
||||
begin
|
||||
fTargetType := ttPoint;
|
||||
fCombatPhase := cpWalk;
|
||||
end
|
||||
else
|
||||
fCombatPhase := cpIdle;
|
||||
|
||||
// Check traffic
|
||||
walkedDistance := KMDistanceAbs(fTrafficDetection.PreviousPosition, fGroup.Position);
|
||||
fTrafficDetection.StuckCounter := min(round(AI_Par[ATTACK_SQUAD_TrafficDetection_Limit]), max(0, Word(fCombatPhase = cpWalk) * fTrafficDetection.StuckCounter + Word(walkedDistance <= 1) * 2 - 1));
|
||||
fTrafficDetection.StuckInTraffic := fTrafficDetection.StuckCounter > AI_Par[ATTACK_SQUAD_TrafficDetection_Threshold];
|
||||
fTrafficDetection.PreviousPosition := fGroup.Position;
|
||||
end;
|
||||
|
||||
|
||||
function TKMCombatGroup.PlanPath(aTick: Cardinal; var aActualPosition, aTargetPosition: TKMPoint; aOrderAttack: Boolean = False; aOrderDestroy: Boolean = False): Boolean;
|
||||
var
|
||||
PathFound: Boolean;
|
||||
InitPolygon, ClosestPolygon, Distance: Word;
|
||||
I: Integer;
|
||||
SQRDist: Single;
|
||||
PointPath: TKMPointArray;
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
Timer: Int64;
|
||||
{$ENDIF}
|
||||
begin
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
Timer := TimeGetUsec();
|
||||
{$ENDIF}
|
||||
Result := False;
|
||||
fOnPlace := False;
|
||||
SQRDist := KMDistanceSqr(aActualPosition, aTargetPosition);
|
||||
// Time limit
|
||||
if (not (aOrderAttack OR aOrderDestroy) AND (fWalkTimeLimit < aTick)) // Time limit is set to 0 in case that unit attack something
|
||||
// Target position is reached
|
||||
OR (SQRDist < sqr(AI_Par[ATTACK_SQUAD_TargetReached_Position]))
|
||||
// Target unit is close
|
||||
OR (aOrderAttack AND (SQRDist < sqr(AI_Par[ATTACK_SQUAD_TargetReached_Unit])))
|
||||
// Target house is close
|
||||
OR (aOrderDestroy AND (SQRDist < sqr(AI_Par[ATTACK_SQUAD_TargetReached_House])))
|
||||
// Archers should start fire as soon as possible
|
||||
OR ((aOrderAttack OR aOrderDestroy) AND (fGroup.GroupType = gtRanged) AND (SQRDist < sqr(AI_Par[ATTACK_SQUAD_TargetReached_RangedSquad]))) then
|
||||
begin
|
||||
fOnPlace := True;
|
||||
Exit;
|
||||
end;
|
||||
// Plan path with respect to enemy presence
|
||||
if aOrderAttack then
|
||||
PathFound := gAIFields.NavMesh.Pathfinding.AvoidEnemyRoute(Group.Owner, Group.GroupType, aActualPosition, aTargetPosition, Distance, PointPath)
|
||||
else if aOrderDestroy then
|
||||
PathFound := gAIFields.NavMesh.Pathfinding.ShortestRoute(aActualPosition, aTargetPosition, Distance, PointPath)
|
||||
else
|
||||
PathFound := gAIFields.NavMesh.Pathfinding.AvoidTrafficRoute(Group.Owner, aActualPosition, aTargetPosition, Distance, PointPath);
|
||||
|
||||
if PathFound then
|
||||
begin
|
||||
if Distance < 5 then
|
||||
begin
|
||||
fOnPlace := True;
|
||||
Exit;
|
||||
end
|
||||
else
|
||||
begin
|
||||
InitPolygon := gAIFields.NavMesh.KMPoint2Polygon[aActualPosition];
|
||||
I := Length(PointPath)-1;
|
||||
repeat
|
||||
aTargetPosition := PointPath[Max(0, I)];
|
||||
ClosestPolygon := gAIFields.NavMesh.KMPoint2Polygon[aTargetPosition];
|
||||
I := I - 1;
|
||||
until (I < 0) or (
|
||||
(InitPolygon <> ClosestPolygon)
|
||||
and (tpWalk in gTerrain.Land^[aTargetPosition.Y, aTargetPosition.X].Passability)
|
||||
and (KMDistanceSqr(aActualPosition, aTargetPosition) > sqr(AI_Par[ATTACK_SQUAD_MinWalkingDistance]))
|
||||
);
|
||||
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
DEBUGPointPath := PointPath;
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
Result := True;
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
gTimePathfinding := gTimePathfinding + TimeGetUsec() - Timer;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
{ TKMArmyAttackNew }
|
||||
constructor TKMArmyAttackNew.Create(aOwner: TKMHandID);
|
||||
begin
|
||||
inherited Create;
|
||||
fCombatGroups := TObjectList<TKMCombatGroup>.Create();
|
||||
fOwner := aOwner;
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
gTimePathfinding := 0;
|
||||
gTimeAiming := 0;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMArmyAttackNew.Destroy;
|
||||
begin
|
||||
fCombatGroups.Free; // Calls also Clear()
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyAttackNew.Save(SaveStream: TKMemoryStream);
|
||||
var
|
||||
K: Integer;
|
||||
begin
|
||||
SaveStream.PlaceMarker('ArmyAttack');
|
||||
SaveStream.Write(fOwner);
|
||||
SaveStream.Write( Integer(Count) );
|
||||
|
||||
for K := 0 to Count - 1 do
|
||||
fCombatGroups[K].Save(SaveStream);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyAttackNew.Load(LoadStream: TKMemoryStream);
|
||||
var
|
||||
K, NewCount: Integer;
|
||||
begin
|
||||
LoadStream.CheckMarker('ArmyAttack');
|
||||
LoadStream.Read(fOwner);
|
||||
LoadStream.Read(NewCount);
|
||||
|
||||
for K := 0 to NewCount - 1 do
|
||||
fCombatGroups.Add( TKMCombatGroup.Load(LoadStream) );
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyAttackNew.SyncLoad();
|
||||
var
|
||||
K: Integer;
|
||||
begin
|
||||
for K := 0 to Count - 1 do
|
||||
fCombatGroups[K].SyncLoad();
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyAttackNew.AfterMissionInit();
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyAttackNew.UpdateState(aTick: Cardinal);
|
||||
var
|
||||
K: Integer;
|
||||
begin
|
||||
// Update target point
|
||||
{
|
||||
for K := fCombatGroups.Count - 1 downto 0 do
|
||||
for L := 0 to Length( gAIFields.Supervisor.fArmyPos.fAllyGroups) - 1 do
|
||||
if ( gAIFields.Supervisor.fArmyPos.fAllyGroups[L] = fCombatGroups[K].Group) then
|
||||
begin
|
||||
if (Length(gAIFields.Supervisor.fArmyPos.TargetPositions) > L) then
|
||||
begin
|
||||
fCombatGroups[K].TargetPosition := KMPointDir(gAIFields.Supervisor.fArmyPos.TargetPositions[L],dirNE);
|
||||
fCombatGroups[K].WalkTimeLimit := aTick + ;
|
||||
end;
|
||||
break;
|
||||
end;
|
||||
}
|
||||
|
||||
// Check state
|
||||
//for K := fCombatGroups.Count - 1 downto 0 do
|
||||
//begin
|
||||
// CG := fCombatGroups.Items[K];
|
||||
// //CG.UpdateState(aTick);
|
||||
//end;
|
||||
|
||||
// Update state
|
||||
for K := fCombatGroups.Count - 1 downto 0 do
|
||||
begin
|
||||
fCombatGroups[K].UpdateState(aTick);
|
||||
if (fCombatGroups[K].CombatPhase = cpDead) then
|
||||
fCombatGroups.Delete(K);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyAttackNew.OwnerUpdate(aPlayer: TKMHandID);
|
||||
begin
|
||||
fOwner := aPlayer;
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyAttackNew.GetCount(): Integer;
|
||||
begin
|
||||
Result := fCombatGroups.Count;
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyAttackNew.GetCombatGroupIdx(aGroup: TKMUnitGroup): Integer;
|
||||
var
|
||||
K: Integer;
|
||||
begin
|
||||
Result := -1;
|
||||
for K := 0 to Count - 1 do
|
||||
if (fCombatGroups[K].Group = aGroup) then
|
||||
Exit(K);
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyAttackNew.GetCombatGroup(aGroup: TKMUnitGroup): TKMCombatGroup;
|
||||
var
|
||||
K: Integer;
|
||||
begin
|
||||
Result := nil;
|
||||
K := GetCombatGroupIdx(aGroup);
|
||||
if (K <> -1) then
|
||||
Result := fCombatGroups[K];
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyAttackNew.IsGroupInAction(aGroup: TKMUnitGroup): Boolean;
|
||||
begin
|
||||
Result := GetCombatGroup(aGroup) <> nil;
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyAttackNew.AddGroup(const aGroup: TKMUnitGroup): TKMCombatGroup;
|
||||
var
|
||||
Idx: Integer;
|
||||
begin
|
||||
Result := nil;
|
||||
if (aGroup <> nil) AND not aGroup.IsDead then
|
||||
begin
|
||||
Result := GetCombatGroup(aGroup);
|
||||
if (Result = nil) then
|
||||
begin
|
||||
Idx := fCombatGroups.Add( TKMCombatGroup.Create(aGroup) );
|
||||
Result := fCombatGroups[Idx];
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyAttackNew.AddGroups(const aGroups: TKMUnitGroupArray);
|
||||
var
|
||||
K: Integer;
|
||||
begin
|
||||
for K := 0 to Length(aGroups) - 1 do
|
||||
AddGroup(aGroups[K]);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyAttackNew.ReleaseGroup(aGroup: TKMUnitGroup);
|
||||
var
|
||||
K: Integer;
|
||||
begin
|
||||
K := GetCombatGroupIdx(aGroup);
|
||||
if (K <> -1) then
|
||||
fCombatGroups.Delete(K);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyAttackNew.ReleaseGroups();
|
||||
begin
|
||||
fCombatGroups.Clear();
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyAttackNew.LinkGroup(aGroup: TKMUnitGroup);
|
||||
var
|
||||
K: Integer;
|
||||
begin
|
||||
for K := 0 to Count - 1 do
|
||||
if (aGroup.GroupType = fCombatGroups[K].Group.GroupType) AND (fCombatGroups[K].Group.Count < 9) then
|
||||
begin
|
||||
if (fCombatGroups[K].Group.Count - 9 <= aGroup.Count) then
|
||||
aGroup.OrderLinkTo(fCombatGroups[K].Group, True)
|
||||
else
|
||||
aGroup.OrderSplitLinkTo(fCombatGroups[K].Group, fCombatGroups[K].Group.Count - 9, True);
|
||||
fCombatGroups[K].Group.UnitsPerRow := Max(3,fCombatGroups[K].Group.UnitsPerRow);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyAttackNew.LogStatus(var aBalanceText: UnicodeString);
|
||||
var
|
||||
K: Integer;
|
||||
Order, GroupOrder: UnicodeString;
|
||||
CG: TKMCombatGroup;
|
||||
begin
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
aBalanceText := Format('%s||Time pathfinding: %d|Time aiming:%d',[aBalanceText,gTimePathfinding,gTimeAiming]);
|
||||
{$ENDIF}
|
||||
if (gMySpectator.Selected is TKMUnitGroup) then
|
||||
for K := 0 to fCombatGroups.Count - 1 do
|
||||
if (gMySpectator.Selected = fCombatGroups[K].Group) then
|
||||
begin
|
||||
CG := fCombatGroups[K];
|
||||
|
||||
Order := 'CGTargets:|';
|
||||
if (CG.TargetGroup <> nil) AND not CG.TargetGroup.IsDead then
|
||||
Order := Format('%s Group [%d;%d] %s|',[Order, CG.TargetGroup.Position.X,CG.TargetGroup.Position.Y, GetEnumName(TypeInfo(TKMGroupType), Integer(CG.TargetGroup.GroupType))]);
|
||||
if (CG.TargetUnit <> nil) AND not CG.TargetUnit.IsDeadOrDying then
|
||||
Order := Format('%s Unit [%d;%d] %s|',[Order, CG.TargetUnit.Position.X,CG.TargetUnit.Position.Y, GetEnumName(TypeInfo(TKMUnitType), Integer(CG.TargetUnit.UnitType))]);
|
||||
if (CG.TargetHouse <> nil) AND not CG.TargetHouse.IsDestroyed then
|
||||
Order := Format('%s House [%d;%d] %s|',[Order, CG.TargetHouse.Entrance.X, CG.TargetHouse.Entrance.Y, GetEnumName(TypeInfo(TKMHouseType), Integer(CG.TargetHouse.HouseType))]);
|
||||
|
||||
GroupOrder := Format('GroupOrder: %s',[GetEnumName(TypeInfo(TKMGroupOrder), Integer(CG.Group.Order))]);
|
||||
if (CG.Group.Order = goWalkTo) then
|
||||
GroupOrder := Format('%s [%d;%d]|', [GroupOrder, CG.Group.OrderLoc.Loc.X, CG.Group.OrderLoc.Loc.Y])
|
||||
else if (CG.Group.Order in [goAttackHouse,goNone]) AND (CG.Group.OrderTargetHouse <> nil) then
|
||||
GroupOrder := Format('%s %d [%d;%d]|', [GroupOrder, Integer(CG.Group.OrderTargetHouse), CG.Group.OrderTargetHouse.Position.X, CG.Group.OrderTargetHouse.Position.Y])
|
||||
else if (CG.Group.Order in [goAttackUnit,goNone]) AND (CG.Group.OrderTargetUnit <> nil) then
|
||||
GroupOrder := Format('%s %d [%d;%d]|', [GroupOrder, Integer(CG.Group.OrderTargetUnit), CG.Group.OrderTargetUnit.Position.X, CG.Group.OrderTargetUnit.Position.Y])
|
||||
else if (CG.Group.Order = goNone) then
|
||||
GroupOrder := Format('%s [%d;%d]|', [GroupOrder, CG.Group.OrderLoc.Loc.X, CG.Group.OrderLoc.Loc.Y]);
|
||||
|
||||
aBalanceText := Format('%s|CG_ID: %d|Group_ID: %d|CombatPhase: %s|TargetType: %s|OnPlace: %d|InFight: %d|%sWalkTimeLimit: %d|AttackTimeLimit: %d|GroupPosition: [%d;%d]|TargetAim: [%d;%d]|DistanceFromAim: Sqr(%f) Abs(%d)|%s', [
|
||||
aBalanceText,
|
||||
Integer(CG),
|
||||
Integer(CG.Group),
|
||||
GetEnumName(TypeInfo(TKMCombatPhase), Integer(CG.CombatPhase)),
|
||||
GetEnumName(TypeInfo(TKMTargetType), Integer(CG.TargetType)),
|
||||
Byte(CG.OnPlace),
|
||||
Byte(CG.InFight),
|
||||
Order,
|
||||
Max(0, Integer(CG.WalkTimeLimit) - Integer(gGameParams.Tick)),
|
||||
Max(0, Integer(CG.AttackTimeLimit) - Integer(gGameParams.Tick)),
|
||||
CG.Position.X, CG.Position.Y,
|
||||
CG.TargetAim.X, CG.TargetAim.Y,
|
||||
KMDistanceSqr(CG.TargetAim,CG.Position), KMDistanceAbs(CG.TargetAim,CG.Position),
|
||||
GroupOrder
|
||||
]);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyAttackNew.Paint;
|
||||
var
|
||||
Op1, Op2: Byte;
|
||||
K: Integer;
|
||||
Col1, Col2: Cardinal;
|
||||
Position: TKMPoint;
|
||||
CG: TKMCombatGroup;
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
L: Integer;
|
||||
{$ENDIF}
|
||||
begin
|
||||
for K := 0 to fCombatGroups.Count - 1 do
|
||||
begin
|
||||
CG := fCombatGroups[K];
|
||||
if CG.fTrafficDetection.StuckInTraffic then
|
||||
gRenderAux.Quad(CG.Position.X, CG.Position.Y, $FF000000 OR tcRed);
|
||||
end;
|
||||
|
||||
|
||||
{$IFDEF DEBUG_NavMeshPathfinding}
|
||||
if (fOwner = gMySpectator.HandID) then
|
||||
gAIFields.NavMesh.Pathfinding.Paint();
|
||||
{$ENDIF}
|
||||
//if (fOwner <> 1) then
|
||||
// Exit;
|
||||
|
||||
for K := 0 to fCombatGroups.Count - 1 do
|
||||
begin
|
||||
CG := fCombatGroups[K];
|
||||
|
||||
// Opacity
|
||||
Op1 := $20;
|
||||
Op2 := $30;
|
||||
if (gMySpectator.Selected is TKMUnitGroup) AND (gMySpectator.Selected = CG.Group) then
|
||||
begin
|
||||
//Col1 := gMySpectator.Hand.FlagColor;
|
||||
Op1 := $AA;
|
||||
Op2 := $FF;
|
||||
case CG.Group.Order of
|
||||
goWalkTo: Position := CG.Group.OrderLoc.Loc;
|
||||
goAttackHouse:
|
||||
begin
|
||||
if (CG.Group.OrderTargetHouse <> nil) then
|
||||
Position := CG.Group.OrderTargetHouse.Position;
|
||||
end;
|
||||
goAttackUnit:
|
||||
begin
|
||||
if (CG.Group.OrderTargetUnit <> nil) then
|
||||
Position := CG.Group.OrderTargetUnit.Position;
|
||||
end;
|
||||
goNone:
|
||||
begin
|
||||
if (CG.Group.OrderTargetHouse <> nil) then
|
||||
Position := CG.Group.OrderTargetHouse.Position
|
||||
else if (CG.Group.OrderTargetUnit <> nil) then
|
||||
Position := CG.Group.OrderTargetUnit.Position
|
||||
else
|
||||
Position := CG.Group.OrderLoc.Loc;
|
||||
end;
|
||||
else begin end; // goStorm, goNone
|
||||
end;
|
||||
if not KMSamePoint(Position,KMPOINT_ZERO) then
|
||||
gRenderAux.CircleOnTerrain(Position.X, Position.Y, 1.5, (Op1 shl 24) OR tcBlue, (Op2 shl 24) OR tcBlue);
|
||||
gRenderAux.Quad(CG.TargetAim.X, CG.TargetAim.Y, $FF000000 OR tcWhite);
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
if not KMSamePoint(CG.TargetAim, KMPOINT_ZERO) AND (Length(CG.DEBUGPointPath) > 0) then
|
||||
with CG.DEBUGPointPath[Low(CG.DEBUGPointPath)] do
|
||||
gRenderAux.Quad(X, Y, $FF000000 OR tcCyan);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
// Combat group circle
|
||||
Col1 := tcWhite;
|
||||
case CG.CombatPhase of
|
||||
cpIdle: Col1 := tcWhite;
|
||||
cpWalk: Col1 := tcGreen;
|
||||
cpAttack: Col1 := tcRed;
|
||||
cpDead: Col1 := tcBlack;
|
||||
end;
|
||||
Col2 := tcWhite;
|
||||
case CG.TargetType of
|
||||
ttNone: Col2 := tcWhite;
|
||||
ttGroup: Col2 := tcRed;
|
||||
ttUnit: Col2 := tcYellow;
|
||||
ttHouse: Col2 := tcYellow;
|
||||
ttPoint: Col2 := tcGreen;
|
||||
end;
|
||||
gRenderAux.CircleOnTerrain(CG.Position.X, CG.Position.Y, 1, (Op1 shl 24) OR Col1, (Op2 shl 24) OR Col2);
|
||||
|
||||
// Select target
|
||||
Col1 := tcWhite;
|
||||
if (CG.CombatPhase = cpWalk) then Col1 := tcGreen
|
||||
else if (CG.CombatPhase = cpAttack) then Col1 := tcRed;
|
||||
{$IFDEF DEBUG_NewAI}
|
||||
if not KMSamePoint(CG.TargetAim, KMPOINT_ZERO) then
|
||||
for L := 1 to Length(CG.DEBUGPointPath) - 1 do
|
||||
gRenderAux.LineOnTerrain(CG.DEBUGPointPath[L-1], CG.DEBUGPointPath[L], (Op2 shl 24) OR Col1);
|
||||
{$ELSE}
|
||||
if not KMSamePoint(CG.TargetAim, KMPOINT_ZERO) then
|
||||
gRenderAux.LineOnTerrain(CG.Position, CG.TargetAim, (Op2 shl 24) OR Col1);
|
||||
{$ENDIF}
|
||||
end;
|
||||
//gRenderAux.Quad(Loc.X, Loc.Y, Color);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
+597
@@ -0,0 +1,597 @@
|
||||
{
|
||||
Artificial intelligence
|
||||
@author: Martin Toupal
|
||||
@e-mail: poznamenany@gmail.com
|
||||
}
|
||||
unit KM_ArmyDefence;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, KM_CommonClasses, KM_CommonTypes, KM_Defaults,
|
||||
KM_Points, KM_UnitGroup, KM_NavMeshDefences, KM_AIDefensePos;
|
||||
|
||||
|
||||
type
|
||||
TKMFormation = record NumUnits, UnitsPerRow: Integer; end;
|
||||
|
||||
TKMDefencePosition = class
|
||||
private
|
||||
fWeight, fLine: Word; // Higher number = higher enemy influence or closer to the first line
|
||||
fGroup: TKMUnitGroup; //Commander of group currently occupying position
|
||||
fPosition: TKMPointDir; //Position and direction the group defending will stand
|
||||
|
||||
procedure SetGroup(aGroup: TKMUnitGroup);
|
||||
procedure SetPosition(const Value: TKMPointDir);
|
||||
function GetGroupType(): TKMGroupType;
|
||||
public
|
||||
constructor Create(aWeight, aLine: Word; aPos: TKMPointDir);
|
||||
constructor Load(LoadStream: TKMemoryStream);
|
||||
destructor Destroy; override;
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure SyncLoad();
|
||||
|
||||
property Line: Word read fLine write fLine;
|
||||
property Weight: Word read fWeight write fWeight;
|
||||
property Position: TKMPointDir read fPosition write SetPosition; //Position and direction the group defending will stand
|
||||
property Group: TKMUnitGroup read fGroup write SetGroup;
|
||||
property GroupType: TKMGroupType read GetGroupType;
|
||||
|
||||
function CanAccept(aGroup: TKMUnitGroup; aMaxUnits: Integer): Boolean;
|
||||
procedure UpdateState(aTick: Cardinal);
|
||||
end;
|
||||
|
||||
|
||||
TKMArmyDefence = class
|
||||
private
|
||||
fOwner: TKMHandID;
|
||||
fCityUnderAttack: Boolean;
|
||||
fFirstLineCnt: Word;
|
||||
fPositions: TKMList;
|
||||
|
||||
function GetCount: Integer; inline;
|
||||
function GetPosition(aIndex: Integer): TKMDefencePosition; inline;
|
||||
function GetGroupsCount(): Word;
|
||||
public
|
||||
TroopFormations: array [GROUP_TYPE_MIN..GROUP_TYPE_MAX] of TKMFormation; //Defines how defending troops will be formatted. 0 means leave unchanged.
|
||||
|
||||
constructor Create(aOwner: TKMHandID);
|
||||
destructor Destroy; override;
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure Load(LoadStream: TKMemoryStream);
|
||||
procedure SyncLoad();
|
||||
|
||||
property Count: Integer read GetCount;
|
||||
property Positions[aIndex: Integer]: TKMDefencePosition read GetPosition; default;
|
||||
property FirstLineCnt: Word read fFirstLineCnt;
|
||||
property GroupsCount: Word read GetGroupsCount;
|
||||
property CityUnderAttack: Boolean read fCityUnderAttack;
|
||||
|
||||
procedure OwnerUpdate(aOwner: TKMHandID);
|
||||
procedure UpdateDefences(aDefCnt: Word; aPNewDef: array of PDefencePosition);
|
||||
procedure UpdateFixedDefences();
|
||||
function DefenceStatus(): Single;
|
||||
function FindPositionOf(aGroup: TKMUnitGroup; aIgnoreFirstLine: Boolean = False): TKMDefencePosition;
|
||||
function FindPlaceForGroup(aGroup: TKMUnitGroup): Boolean;
|
||||
procedure ReleaseGroup(aGroup: TKMUnitGroup); overload;
|
||||
procedure ReleaseGroup(aDefPosIdx: Integer); overload;
|
||||
function ReleaseAllGroups(): TKMUnitGroupArray;
|
||||
|
||||
procedure AfterMissionInit();
|
||||
procedure UpdateState(aTick: Cardinal);
|
||||
procedure LogStatus(var aBalanceText: UnicodeString);
|
||||
procedure Paint();
|
||||
end;
|
||||
|
||||
const
|
||||
MAX_SOLDIERS_IN_GROUP = 9; //These are the defaults in KaM
|
||||
FORMATION_OF_GROUP = 3;
|
||||
SQR_FIRST_LINE_RADIUS = 8*8;
|
||||
FIRST_LINE_MAX_IDX = 0;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Math,
|
||||
KM_Entity,
|
||||
KM_GameParams, KM_HandsCollection, KM_Hand, KM_RenderAux,
|
||||
KM_AIFields, KM_NavMesh,
|
||||
KM_UnitGroupTypes;
|
||||
|
||||
|
||||
{ TKMDefencePosition }
|
||||
constructor TKMDefencePosition.Create(aWeight, aLine: Word; aPos: TKMPointDir);
|
||||
begin
|
||||
inherited Create;
|
||||
fWeight := aWeight;
|
||||
fLine := aLine;
|
||||
fPosition := aPos;
|
||||
Group := nil; //Unoccupied
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMDefencePosition.Destroy;
|
||||
begin
|
||||
Group := nil; //Ensure pointer is removed (property calls CleanUpGroupPointer)
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDefencePosition.Save(SaveStream: TKMemoryStream);
|
||||
begin
|
||||
SaveStream.PlaceMarker('AdvDefencePosition');
|
||||
SaveStream.Write(fWeight);
|
||||
SaveStream.Write(fLine);
|
||||
SaveStream.Write(fPosition);
|
||||
SaveStream.Write(fGroup.UID); //Store ID
|
||||
end;
|
||||
|
||||
|
||||
constructor TKMDefencePosition.Load(LoadStream: TKMemoryStream);
|
||||
begin
|
||||
inherited Create;
|
||||
LoadStream.CheckMarker('AdvDefencePosition');
|
||||
LoadStream.Read(fWeight);
|
||||
LoadStream.Read(fLine);
|
||||
LoadStream.Read(fPosition);
|
||||
LoadStream.Read(fGroup, 4); //Subst on syncload
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDefencePosition.SyncLoad();
|
||||
begin
|
||||
fGroup := gHands.GetGroupByUID(Integer(fGroup));
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDefencePosition.SetGroup(aGroup: TKMUnitGroup);
|
||||
begin
|
||||
gHands.CleanUpGroupPointer(fGroup);
|
||||
if (aGroup <> nil) then
|
||||
fGroup := aGroup.GetPointer;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDefencePosition.SetPosition(const Value: TKMPointDir);
|
||||
begin
|
||||
Assert(gGameParams.IsMapEditor);
|
||||
fPosition := Value;
|
||||
end;
|
||||
|
||||
|
||||
function TKMDefencePosition.GetGroupType(): TKMGroupType;
|
||||
begin
|
||||
Result := gtMelee;
|
||||
if (Group <> nil) then
|
||||
Result := Group.GroupType;
|
||||
end;
|
||||
|
||||
|
||||
function TKMDefencePosition.CanAccept(aGroup: TKMUnitGroup; aMaxUnits: Integer): Boolean;
|
||||
begin
|
||||
Result := (Group = nil)
|
||||
or ((GroupType = UNIT_TO_GROUP_TYPE[aGroup.UnitType]) and (Group.Count < aMaxUnits));
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDefencePosition.UpdateState(aTick: Cardinal);
|
||||
begin
|
||||
// If the group is Dead or too far away we should disassociate
|
||||
// them from the defence position so new warriors can take up the defence if needs be
|
||||
if (Group = nil)
|
||||
or Group.IsDead
|
||||
or Group.InFight
|
||||
or (Group.Order in [goAttackHouse, goAttackUnit]) then
|
||||
gHands.CleanUpGroupPointer(fGroup);
|
||||
|
||||
// Tell group to walk to its position
|
||||
// It's easier to repeat the order than check that all members are in place
|
||||
if (Group <> nil)
|
||||
and Group.IsIdleToAI([wtokFlagPoint, wtokHaltOrder])
|
||||
and Group.CanWalkTo(Position.Loc, 0) then
|
||||
Group.OrderWalk(Position.Loc, True, wtokAIGotoDefencePos, Position.Dir);
|
||||
end;
|
||||
|
||||
|
||||
{ TKMArmyDefence }
|
||||
constructor TKMArmyDefence.Create(aOwner: TKMHandID);
|
||||
var
|
||||
GT: TKMGroupType;
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
fOwner := aOwner;
|
||||
fCityUnderAttack := False;
|
||||
fPositions := TKMList.Create;
|
||||
|
||||
for GT := GROUP_TYPE_MIN to GROUP_TYPE_MAX do
|
||||
begin
|
||||
TroopFormations[GT].NumUnits := MAX_SOLDIERS_IN_GROUP;
|
||||
TroopFormations[GT].UnitsPerRow := FORMATION_OF_GROUP;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMArmyDefence.Destroy;
|
||||
begin
|
||||
fPositions.Free;
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyDefence.Save(SaveStream: TKMemoryStream);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
SaveStream.PlaceMarker('AdvDefencePositions');
|
||||
SaveStream.Write(fOwner);
|
||||
SaveStream.Write(fCityUnderAttack);
|
||||
SaveStream.Write(fFirstLineCnt);
|
||||
SaveStream.Write(TroopFormations, SizeOf(TroopFormations));
|
||||
|
||||
SaveStream.Write(Count);
|
||||
for I := 0 to Count - 1 do
|
||||
Positions[I].Save(SaveStream);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyDefence.Load(LoadStream: TKMemoryStream);
|
||||
var
|
||||
I, newCount: Integer;
|
||||
begin
|
||||
LoadStream.CheckMarker('AdvDefencePositions');
|
||||
LoadStream.Read(fOwner);
|
||||
LoadStream.Read(fCityUnderAttack);
|
||||
LoadStream.Read(fFirstLineCnt);
|
||||
LoadStream.Read(TroopFormations, SizeOf(TroopFormations));
|
||||
|
||||
LoadStream.Read(newCount);
|
||||
for I := 0 to newCount - 1 do
|
||||
fPositions.Add( TKMDefencePosition.Load(LoadStream) );
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyDefence.SyncLoad;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
for I := 0 to Count - 1 do
|
||||
Positions[I].SyncLoad;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyDefence.OwnerUpdate(aOwner: TKMHandID);
|
||||
begin
|
||||
fOwner := aOwner;
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyDefence.GetCount: Integer;
|
||||
begin
|
||||
Result := fPositions.Count;
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyDefence.GetPosition(aIndex: Integer): TKMDefencePosition;
|
||||
begin
|
||||
Result := fPositions[aIndex];
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyDefence.GetGroupsCount(): Word;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
for I := 0 to Count - 1 do
|
||||
Inc(Result, Ord(Positions[I].Group <> nil));
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyDefence.FindPlaceForGroup(aGroup: TKMUnitGroup): Boolean;
|
||||
var
|
||||
K, BestIdx, Needed: Integer;
|
||||
BestWeight: Word;
|
||||
UG: TKMUnitGroup;
|
||||
begin
|
||||
Result := False;
|
||||
|
||||
//Try to link to existing group
|
||||
BestWeight := 0;
|
||||
BestIdx := -1;
|
||||
for K := 0 to Count - 1 do
|
||||
if Positions[K].CanAccept(aGroup, TroopFormations[aGroup.GroupType].NumUnits)
|
||||
AND (BestWeight < Positions[K].Weight) then
|
||||
begin
|
||||
BestIdx := K;
|
||||
BestWeight := Positions[K].Weight;
|
||||
end;
|
||||
|
||||
if (BestIdx <> -1) then
|
||||
begin
|
||||
Result := True;
|
||||
//New position
|
||||
if (Positions[BestIdx].Group = nil) then
|
||||
begin
|
||||
Needed := TroopFormations[aGroup.GroupType].NumUnits;
|
||||
// Add group to new defense position
|
||||
Positions[BestIdx].Group := aGroup;
|
||||
// Defence position requires less soldiers -> distribute other soldiers into different defence position
|
||||
if (aGroup.Count > Needed) then
|
||||
begin
|
||||
UG := aGroup.OrderSplitUnit(aGroup.GetAliveMember, True);
|
||||
if (UG <> nil) then
|
||||
begin
|
||||
if (aGroup.Count - Needed > 0) then
|
||||
aGroup.OrderSplitLinkTo(UG, aGroup.Count - Needed, True); //Link only as many units as are needed
|
||||
//FindPlaceForGroup(UG); // The rest of group will be added later (not in this tick)
|
||||
end;
|
||||
end;
|
||||
UG := Positions[BestIdx].Group;
|
||||
UG.OrderWalk(Positions[BestIdx].Position.Loc, True, wtokAIGotoDefencePos, Positions[BestIdx].Position.Dir);
|
||||
end
|
||||
// Restock
|
||||
else
|
||||
begin
|
||||
//Append to existing position
|
||||
UG := Positions[BestIdx].Group;
|
||||
Needed := TroopFormations[ UG.GroupType ].NumUnits - UG.Count;
|
||||
if (aGroup.Count <= Needed) then
|
||||
aGroup.OrderLinkTo(UG, True) //Link entire group
|
||||
else
|
||||
begin
|
||||
aGroup.OrderSplitLinkTo(UG, Needed, True); //Link only as many units as are needed
|
||||
//FindPlaceForGroup(aGroup); // The rest of group will be added later (not in this tick)
|
||||
end;
|
||||
end;
|
||||
if (UG.UnitsPerRow <> TroopFormations[UG.GroupType].UnitsPerRow) then
|
||||
UG.UnitsPerRow := TroopFormations[UG.GroupType].UnitsPerRow;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
// Find DefencePosition of a group
|
||||
function TKMArmyDefence.FindPositionOf(aGroup: TKMUnitGroup; aIgnoreFirstLine: Boolean = False): TKMDefencePosition;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
Result := nil;
|
||||
|
||||
for I := 0 to Count - 1 do
|
||||
if (Positions[I].Group = aGroup) then
|
||||
begin
|
||||
if (aIgnoreFirstLine and (Positions[I].Line <= FIRST_LINE_MAX_IDX)) then
|
||||
Break;
|
||||
Result := Positions[I];
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyDefence.ReleaseGroup(aGroup: TKMUnitGroup);
|
||||
var
|
||||
DP: TKMDefencePosition;
|
||||
begin
|
||||
DP := FindPositionOf(aGroup);
|
||||
if (DP <> nil) then
|
||||
DP.Group := nil;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyDefence.ReleaseGroup(aDefPosIdx: Integer);
|
||||
begin
|
||||
if (aDefPosIdx < Count) then
|
||||
Positions[aDefPosIdx].Group := nil;
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyDefence.ReleaseAllGroups(): TKMUnitGroupArray;
|
||||
var
|
||||
K, Cnt: Integer;
|
||||
begin
|
||||
Cnt := GroupsCount;
|
||||
SetLength(Result, Cnt);
|
||||
for K := 0 to Count - 1 do
|
||||
if (Positions[K].Group <> nil) then
|
||||
begin
|
||||
Dec(Cnt);
|
||||
Result[Cnt] := Positions[K].Group;
|
||||
ReleaseGroup(K);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
// Defence status = fulfill of first defence line
|
||||
function TKMArmyDefence.DefenceStatus(): Single;
|
||||
var
|
||||
I, Cnt: Integer;
|
||||
begin
|
||||
Result := 0; // No defences
|
||||
if (Count > 0) then
|
||||
begin
|
||||
Cnt := 0;
|
||||
for I := 0 to Count - 1 do
|
||||
if (Positions[I].Group <> nil) then
|
||||
Inc(Cnt);
|
||||
Result := Cnt / Max(1,fFirstLineCnt);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyDefence.UpdateDefences(aDefCnt: Word; aPNewDef: array of PDefencePosition);
|
||||
var
|
||||
I, K: Integer;
|
||||
G: TKMUnitGroup;
|
||||
VisitedNewPos, VisitedExistPos: TBooleanArray;
|
||||
begin
|
||||
//Get defence Polygons
|
||||
if (aDefCnt = 0) then
|
||||
Exit;
|
||||
|
||||
SetLength(VisitedNewPos, aDefCnt);
|
||||
FillChar(VisitedNewPos[0], SizeOf(VisitedNewPos[0])*Length(VisitedNewPos), #0);
|
||||
SetLength(VisitedExistPos, fPositions.Count);
|
||||
if (Length(VisitedExistPos) > 0) then
|
||||
FillChar(VisitedExistPos[0], SizeOf(VisitedExistPos[0])*Length(VisitedExistPos), #0);
|
||||
|
||||
// Compare new defences with old version and add new defences / remove old
|
||||
for I := 0 to aDefCnt - 1 do
|
||||
// Try find existing defence position
|
||||
for K := 0 to fPositions.Count - 1 do
|
||||
//if (Positions[K].Polygon = aPNewDef[I]^.Polygon) then // This cannot be used because 1 polygon can have 3 points
|
||||
if KMSamePoint(Positions[K].Position.Loc, aPNewDef[I]^.DirPoint.Loc) then
|
||||
begin
|
||||
VisitedNewPos[I] := True;
|
||||
VisitedExistPos[K] := True;
|
||||
Positions[K].Weight := aPNewDef[I]^.Weight;
|
||||
Positions[K].Line := aPNewDef[I]^.Line;
|
||||
break;
|
||||
end;
|
||||
|
||||
// Remove old and unused defence positions
|
||||
for I := fPositions.Count - 1 downto 0 do
|
||||
if not VisitedExistPos[I] then
|
||||
fPositions.Delete(I);
|
||||
|
||||
// Add new defence positions
|
||||
for I := 0 to aDefCnt - 1 do
|
||||
if not VisitedNewPos[I] then
|
||||
fPositions.Add( TKMDefencePosition.Create( aPNewDef[I]^.Weight, aPNewDef[I]^.Line, aPNewDef[I]^.DirPoint ) );
|
||||
// Recalculate group positions in case that group is not complete and get count of first line
|
||||
fFirstLineCnt := 0;
|
||||
for I := fPositions.Count - 1 downto 0 do
|
||||
begin
|
||||
if (Positions[I].Line <= FIRST_LINE_MAX_IDX) then
|
||||
Inc(fFirstLineCnt);
|
||||
G := Positions[I].Group;
|
||||
if (G <> nil) AND (G.Count < TroopFormations[ G.GroupType ].NumUnits) then
|
||||
begin
|
||||
ReleaseGroup(I);
|
||||
if not G.IsDead then
|
||||
FindPlaceForGroup(G);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyDefence.UpdateFixedDefences();
|
||||
var
|
||||
K: Integer;
|
||||
DefPos: TAIDefencePosition;
|
||||
DP: TKMDefencePosArr;
|
||||
aPNewDef: array of PDefencePosition;
|
||||
begin
|
||||
with gHands[fOwner].AI.General.DefencePositions do
|
||||
begin
|
||||
SetLength(DP,Count);
|
||||
SetLength(aPNewDef,Count);
|
||||
for K := 0 to Count - 1 do
|
||||
begin
|
||||
DefPos := Positions[K];
|
||||
DP[K].Line := 1;
|
||||
DP[K].Polygon := 0;
|
||||
DP[K].Weight := 1;
|
||||
DP[K].DirPoint := DefPos.Position;
|
||||
aPNewDef[K] := @DP[K];
|
||||
end;
|
||||
UpdateDefences(Count, aPNewDef);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyDefence.AfterMissionInit();
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyDefence.UpdateState(aTick: Cardinal);
|
||||
const
|
||||
FAST_UPDATE = MAX_HANDS * 5;
|
||||
SLOW_UPDATE = MAX_HANDS * 20;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
if (aTick mod FAST_UPDATE = fOwner) then
|
||||
begin
|
||||
for I := 0 to Count - 1 do
|
||||
Positions[I].UpdateState(aTick);
|
||||
if (aTick mod SLOW_UPDATE = fOwner) AND not gHands[fOwner].AI.Setup.AutoDefend then
|
||||
UpdateFixedDefences();
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyDefence.LogStatus(var aBalanceText: UnicodeString);
|
||||
begin
|
||||
//aBalanceText := '';
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyDefence.Paint();
|
||||
var
|
||||
I, K, Idx, Threat, AllianceIdx: Integer;
|
||||
Col: Cardinal;
|
||||
Loc, Pos: TKMPoint;
|
||||
GT: TKMGroupType;
|
||||
UGA: TKMUnitGroupArray;
|
||||
begin
|
||||
if not OVERLAY_DEFENCES then
|
||||
Exit;
|
||||
|
||||
if (fOwner <> gMySpectator.HandID) then // Show just 1 player (it prevents notification to be mess)
|
||||
Exit;
|
||||
|
||||
// Draw defensive positions as a circles
|
||||
for I := 0 to Count - 1 do
|
||||
begin
|
||||
Loc := Positions[I].Position.Loc;
|
||||
Col := $22;
|
||||
if (Positions[I].Group = nil) then
|
||||
Col := 0;
|
||||
gRenderAux.CircleOnTerrain(Loc.X, Loc.Y, 1, (Col shl 24) OR tcGreen, $FFFFFFFF);
|
||||
end;
|
||||
|
||||
// Draw defence position of selected unit
|
||||
if (gMySpectator.Selected is TKMUnitGroup) then
|
||||
for I := 0 to Count - 1 do
|
||||
if (gMySpectator.Selected = Positions[I].Group) then
|
||||
begin
|
||||
Loc := Positions[I].Position.Loc;
|
||||
gRenderAux.CircleOnTerrain(Loc.X, Loc.Y, 1, $AA000000 OR tcRed, $FFFFFFFF);
|
||||
break;
|
||||
end;
|
||||
|
||||
if not gAIFields.Influences.GetAllianceIdx(fOwner,AllianceIdx) then
|
||||
Exit;
|
||||
// First line of defences
|
||||
for I := 0 to fPositions.Count - 1 do
|
||||
if (Positions[I].Line = 0) then
|
||||
begin
|
||||
Loc := Positions[I].Position.Loc;
|
||||
Idx := gAIFields.NavMesh.KMPoint2Polygon[Loc];
|
||||
Threat := 0;
|
||||
for GT := GROUP_TYPE_MIN to GROUP_TYPE_MAX do
|
||||
Threat := Threat + gAIFields.Influences.Presence[ AllianceIdx, Idx, GT ];
|
||||
|
||||
// Draw defensive lines as a triangles
|
||||
Col := Max( $22, Min($FF, Threat) );
|
||||
gAIFields.NavMesh.DrawPolygon(Idx, Col, tcRed);
|
||||
|
||||
// Draw hostile units around defensive lines
|
||||
if (Threat > 0) then
|
||||
begin
|
||||
UGA := gHands.GetGroupsInRadius(Loc, SQR_FIRST_LINE_RADIUS, fOwner, atEnemy);
|
||||
for K := 0 to Length(UGA) - 1 do
|
||||
begin
|
||||
Pos := UGA[K].Position;
|
||||
gRenderAux.CircleOnTerrain(Pos.X, Pos.Y, 1, $44000000 OR tcRed, $FF000000 OR tcRed);
|
||||
//gRenderAux.LineOnTerrain(Pos, Loc, $AA000000 OR clBlack);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
@@ -0,0 +1,586 @@
|
||||
{
|
||||
Artificial intelligence
|
||||
@author: Martin Toupal
|
||||
@e-mail: poznamenany@gmail.com
|
||||
}
|
||||
unit KM_ArmyManagement;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, KromUtils, Math, SysUtils,
|
||||
KM_CommonClasses, KM_Defaults, KM_Points,
|
||||
KM_Houses, KM_Units,
|
||||
KM_UnitGroup, KM_AISetup, KM_ResTypes,
|
||||
KM_HandStats, KM_ArmyDefence, KM_AIAttacks, KM_ArmyAttackNew;
|
||||
|
||||
const
|
||||
ARMY_VECTOR_SCAN_HOUSES_DEF: TKMHouseTypeSet = [htBarracks, htStore, htSchool, htTownhall]; // htWatchTower
|
||||
|
||||
type
|
||||
// Agent interface (for Supervisor)
|
||||
TKMAttackRequest = record
|
||||
Active, FoodShortage, FFA: Boolean;
|
||||
BestAllianceCmp,WorstAllianceCmp: Single;
|
||||
BestEnemy: TKMHandID; // or index of Enemies array
|
||||
Enemies: TKMHandIDArray;
|
||||
end;
|
||||
|
||||
TKMArmyManagement = class
|
||||
private
|
||||
fOwner: TKMHandID;
|
||||
fSetup: TKMHandAISetup;
|
||||
fFoodProblems: Boolean;
|
||||
fLastEquippedTimeIron, fLastEquippedTimeLeather: Cardinal;
|
||||
fAttackRequest: TKMAttackRequest;
|
||||
fArmyVectorFieldScanHouses: TKMHouseTypeSet;
|
||||
|
||||
fAttackNew: TKMArmyAttackNew;
|
||||
fDefence: TKMArmyDefence;
|
||||
|
||||
fBalanceText: UnicodeString;
|
||||
|
||||
procedure RecruitSoldiers;
|
||||
procedure CheckGroupsState;
|
||||
procedure CheckAttack;
|
||||
procedure SetAttackRequest(aAttackRequest: TKMAttackRequest);
|
||||
|
||||
function CombineBalanceStrings: UnicodeString;
|
||||
public
|
||||
constructor Create(aPlayer: TKMHandID; aSetup: TKMHandAISetup);
|
||||
destructor Destroy; override;
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure Load(LoadStream: TKMemoryStream);
|
||||
procedure SyncLoad;
|
||||
|
||||
property AttackNew: TKMArmyAttackNew read fAttackNew;
|
||||
property Defence: TKMArmyDefence read fDefence write fDefence;
|
||||
property AttackRequest: TKMAttackRequest read fAttackRequest write SetAttackRequest;
|
||||
property BalanceText: UnicodeString read CombineBalanceStrings;
|
||||
|
||||
property ArmyVectorFieldScanHouses: TKMHouseTypeSet read fArmyVectorFieldScanHouses write fArmyVectorFieldScanHouses;
|
||||
|
||||
procedure AfterMissionInit;
|
||||
procedure UpdateState(aTick: Cardinal);
|
||||
procedure OwnerUpdate(aPlayer: TKMHandID);
|
||||
procedure WarriorEquipped(aGroup: TKMUnitGroup);
|
||||
|
||||
procedure Paint;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
KM_Game, KM_GameParams,
|
||||
KM_Hand, KM_HandsCollection, KM_HandTypes, KM_HandEntity,
|
||||
KM_Terrain,
|
||||
KM_HouseBarracks,
|
||||
KM_CommonUtils,
|
||||
KM_DevPerfLog, KM_DevPerfLogTypes,
|
||||
KM_AITypes, KM_AIFields,
|
||||
KM_MapTypes;
|
||||
|
||||
|
||||
{ TKMArmyManagement }
|
||||
constructor TKMArmyManagement.Create(aPlayer: TKMHandID; aSetup: TKMHandAISetup);
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
fOwner := aPlayer;
|
||||
fSetup := aSetup;
|
||||
fFoodProblems := False;
|
||||
fLastEquippedTimeIron := 0;
|
||||
fLastEquippedTimeLeather := 0;
|
||||
fArmyVectorFieldScanHouses := ARMY_VECTOR_SCAN_HOUSES_DEF;
|
||||
fAttackRequest.Active := False;
|
||||
|
||||
fAttackNew := TKMArmyAttackNew.Create(aPlayer);
|
||||
fDefence := TKMArmyDefence.Create(aPlayer);
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMArmyManagement.Destroy;
|
||||
begin
|
||||
fAttackNew.Free;
|
||||
fDefence.Free;
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyManagement.Save(SaveStream: TKMemoryStream);
|
||||
begin
|
||||
SaveStream.PlaceMarker('ArmyManagement');
|
||||
SaveStream.Write(fOwner);
|
||||
SaveStream.Write(fFoodProblems);
|
||||
SaveStream.Write(fLastEquippedTimeIron);
|
||||
SaveStream.Write(fLastEquippedTimeLeather);
|
||||
SaveStream.Write(fArmyVectorFieldScanHouses, SizeOf(fArmyVectorFieldScanHouses));
|
||||
|
||||
with fAttackRequest do
|
||||
begin
|
||||
SaveStream.Write(Active);
|
||||
SaveStream.Write(FoodShortage);
|
||||
SaveStream.Write(FFA);
|
||||
SaveStream.Write(BestAllianceCmp);
|
||||
SaveStream.Write(WorstAllianceCmp);
|
||||
SaveStream.Write(BestEnemy);
|
||||
SaveStream.Write( Integer(Length(Enemies)) );
|
||||
if (Length(Enemies) > 0) then
|
||||
SaveStream.Write(Enemies[0], SizeOf(Enemies[0])*Length(Enemies));
|
||||
end;
|
||||
|
||||
fAttackNew.Save(SaveStream);
|
||||
fDefence.Save(SaveStream);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyManagement.Load(LoadStream: TKMemoryStream);
|
||||
var
|
||||
Count: Integer;
|
||||
begin
|
||||
LoadStream.CheckMarker('ArmyManagement');
|
||||
LoadStream.Read(fOwner);
|
||||
LoadStream.Read(fFoodProblems);
|
||||
LoadStream.Read(fLastEquippedTimeIron);
|
||||
LoadStream.Read(fLastEquippedTimeLeather);
|
||||
LoadStream.Read(fArmyVectorFieldScanHouses, SizeOf(fArmyVectorFieldScanHouses));
|
||||
|
||||
with fAttackRequest do
|
||||
begin
|
||||
LoadStream.Read(Active);
|
||||
LoadStream.Read(FoodShortage);
|
||||
LoadStream.Read(FFA);
|
||||
LoadStream.Read(BestAllianceCmp);
|
||||
LoadStream.Read(WorstAllianceCmp);
|
||||
LoadStream.Read(BestEnemy);
|
||||
LoadStream.Read(Count);
|
||||
SetLength(Enemies,Count);
|
||||
if (Length(Enemies) > 0) then
|
||||
LoadStream.Read(Enemies[0], SizeOf(Enemies[0])*Length(Enemies));
|
||||
end;
|
||||
|
||||
fAttackNew.Load(LoadStream);
|
||||
fDefence.Load(LoadStream);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyManagement.SyncLoad;
|
||||
begin
|
||||
fAttackNew.SyncLoad;
|
||||
fDefence.SyncLoad;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyManagement.AfterMissionInit;
|
||||
begin
|
||||
fAttackNew.AfterMissionInit;
|
||||
fDefence.AfterMissionInit;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyManagement.OwnerUpdate(aPlayer: TKMHandID);
|
||||
begin
|
||||
fOwner := aPlayer;
|
||||
fAttackNew.OwnerUpdate(aPlayer);
|
||||
fDefence.OwnerUpdate(aPlayer);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyManagement.WarriorEquipped(aGroup: TKMUnitGroup);
|
||||
begin
|
||||
//if (gAIFields.Supervisor.CombatStatus[fOwner,fOwner] = csDefending) AND (fDefence.GroupsCount = 0) AND (fAttackNew.Count > 0) then
|
||||
if (fDefence.GroupsCount = 0) AND (fAttackNew.Count > 0) AND not fFoodProblems then
|
||||
fAttackNew.LinkGroup(aGroup);
|
||||
if (aGroup.Count > 0) then
|
||||
fDefence.FindPlaceForGroup(aGroup);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyManagement.RecruitSoldiers;
|
||||
function CanEquipIron: Boolean;
|
||||
begin
|
||||
Result := not (fSetup.ArmyType = atLeather)
|
||||
and (fSetup.UnlimitedEquip or gGame.CheckTime(fLastEquippedTimeIron + fSetup.EquipRateIron));
|
||||
end;
|
||||
function CanEquipLeather: Boolean;
|
||||
begin
|
||||
Result := not (fSetup.ArmyType = atIron)
|
||||
and (fSetup.UnlimitedEquip or gGame.CheckTime(fLastEquippedTimeLeather + fSetup.EquipRateLeather));
|
||||
end;
|
||||
var
|
||||
H: TKMHouse;
|
||||
GT: TKMGroupType;
|
||||
K,L: Integer;
|
||||
UT: TKMUnitType;
|
||||
pEquippedTime: ^Cardinal;
|
||||
GroupReq: TKMGroupTypeArray;
|
||||
Barracks: array of TKMHouseBarracks;
|
||||
begin
|
||||
// Peace time; Max soldiers limit reached; cannot equip; no Barracks
|
||||
if gGame.IsPeaceTime
|
||||
or ((fSetup.MaxSoldiers <> -1) and (gHands[fOwner].Stats.GetArmyCount >= fSetup.MaxSoldiers))
|
||||
or (not CanEquipIron and not CanEquipLeather)
|
||||
or (gHands[fOwner].Stats.GetHouseQty(htBarracks) = 0)
|
||||
or (fDefence.Count = 0) then
|
||||
Exit;
|
||||
|
||||
// Take required warriors from CityManagement (-> implemented consideration of required units + save time)
|
||||
FillChar(GroupReq, SizeOf(GroupReq), #0); //Clear up
|
||||
for GT := GROUP_TYPE_MIN to GROUP_TYPE_MAX do
|
||||
for K := Low(AI_TROOP_TRAIN_ORDER[GT]) to High(AI_TROOP_TRAIN_ORDER[GT]) do
|
||||
if (AI_TROOP_TRAIN_ORDER[GT,K] <> utNone) then
|
||||
Inc(GroupReq[GT], gHands[fOwner].AI.CityManagement.WarriorsDemands[ AI_TROOP_TRAIN_ORDER[GT,K] ] + 1); // Always recruit something
|
||||
|
||||
// Find barracks
|
||||
SetLength(Barracks, gHands[fOwner].Stats.GetHouseQty(htBarracks));
|
||||
for K := 0 to Length(Barracks) - 1 do
|
||||
Barracks[K] := nil; // Just to be sure
|
||||
L := 0;
|
||||
for K := 0 to gHands[fOwner].Houses.Count - 1 do
|
||||
begin
|
||||
H := gHands[fOwner].Houses[K];
|
||||
if (H <> nil) AND not H.IsDestroyed AND (H.HouseType = htBarracks) AND H.IsComplete then
|
||||
begin
|
||||
Barracks[L] := TKMHouseBarracks(H);
|
||||
Inc(L);
|
||||
end;
|
||||
end;
|
||||
|
||||
// Train troops where possible in each barracks
|
||||
for K := Low(Barracks) to High(Barracks) do
|
||||
if (Barracks[K] <> nil) then
|
||||
begin
|
||||
// Chose a random group type that we are going to attempt to train (so we don't always train certain group types first)
|
||||
L := 0;
|
||||
repeat
|
||||
GT := TKMGroupType(GROUP_TYPE_MIN_OFF + KaMRandom(4{$IFDEF DBG_RNG_SPY}, 'TKMArmyManagement.RecruitSoldiers'{$ENDIF})); //Pick random from overall count
|
||||
Inc(L);
|
||||
until (GroupReq[GT] > 0) or (L > 9); // Limit number of attempts to guarantee it doesn't loop forever
|
||||
|
||||
if (GroupReq[GT] = 0) then
|
||||
Continue; // Don't train
|
||||
|
||||
for L := Low(AI_TROOP_TRAIN_ORDER[GT]) to High(AI_TROOP_TRAIN_ORDER[GT]) do
|
||||
begin
|
||||
UT := AI_TROOP_TRAIN_ORDER[GT, L];
|
||||
if (UT <> utNone) then
|
||||
begin
|
||||
if CanEquipIron and (UT in WARRIORS_IRON) then
|
||||
pEquippedTime := @fLastEquippedTimeIron
|
||||
else
|
||||
if CanEquipLeather and not (UT in WARRIORS_IRON) then
|
||||
pEquippedTime := @fLastEquippedTimeLeather
|
||||
else
|
||||
Continue;
|
||||
|
||||
while Barracks[K].CanEquip(UT)
|
||||
and (GroupReq[GT] > 0)
|
||||
and ((fSetup.MaxSoldiers = -1) or (gHands[fOwner].Stats.GetArmyCount < fSetup.MaxSoldiers)) do
|
||||
begin
|
||||
Barracks[K].Equip(UT, 1);
|
||||
Dec(GroupReq[GT]);
|
||||
pEquippedTime^ := gGameParams.Tick; // Only reset it when we actually trained something (in IronThenLeather mode we don't count them separately)
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
//Check army food level and positioning
|
||||
procedure TKMArmyManagement.CheckGroupsState;
|
||||
var
|
||||
K: Integer;
|
||||
Group: TKMUnitGroup;
|
||||
begin
|
||||
// Update food level
|
||||
fFoodProblems := gAIFields.Eye.ArmyEvaluation.CheckFoodProblems([fOwner]);
|
||||
|
||||
// Feed army and find unused groups
|
||||
for K := 0 to gHands[fOwner].UnitGroups.Count - 1 do
|
||||
begin
|
||||
Group := gHands[fOwner].UnitGroups[K];
|
||||
|
||||
if (Group <> nil) AND not Group.IsDead AND not Group.InFight then
|
||||
begin
|
||||
// Check hunger and order food
|
||||
if (Group.Condition < UNIT_MIN_CONDITION) AND not fFoodProblems then
|
||||
// Cheat for autobuild AI: Only feed hungry group members (food consumption lower and more predictable)
|
||||
Group.OrderFood(True, fSetup.AutoBuild);
|
||||
|
||||
// Do not process attack or defence during peacetime
|
||||
if gGame.IsPeaceTime then
|
||||
Continue;
|
||||
|
||||
// Group is in combat classes
|
||||
if fAttackNew.IsGroupInAction(Group) then
|
||||
Continue;
|
||||
|
||||
// Group is in defence position
|
||||
if (fDefence.FindPositionOf(Group) <> nil) then
|
||||
Continue;
|
||||
|
||||
if (fDefence.GroupsCount = 0) AND (fAttackNew.Count > 0) then
|
||||
fAttackNew.LinkGroup(Group);
|
||||
|
||||
if (Group.Count > 0) then
|
||||
fDefence.FindPlaceForGroup(Group);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyManagement.CheckAttack;
|
||||
type
|
||||
TKMAvailableGroups = record
|
||||
Count: Word;
|
||||
GroupsAvailable: TKMGroupTypeArray;
|
||||
MenAvailable: TKMGroupTypeArray;
|
||||
GroupArr: TKMUnitGroupArray;
|
||||
end;
|
||||
// Find all available groups
|
||||
function GetGroups(aMobilizationCoef: Single): TKMAvailableGroups;
|
||||
const
|
||||
MIN_TROOPS_IN_GROUP = 4;
|
||||
var
|
||||
K: Integer;
|
||||
Group: TKMUnitGroup;
|
||||
AG: TKMAvailableGroups;
|
||||
DP: TKMDefencePosition;
|
||||
begin
|
||||
AG.Count := 0;
|
||||
SetLength(AG.GroupArr, gHands[fOwner].UnitGroups.Count);
|
||||
for K := 0 to gHands[fOwner].UnitGroups.Count - 1 do
|
||||
begin
|
||||
Group := gHands[fOwner].UnitGroups[K];
|
||||
if (Group = nil)
|
||||
OR Group.IsDead
|
||||
//OR not Group.IsIdleToAI([wtokFlagPoint, wtokHaltOrder])
|
||||
OR ((aMobilizationCoef < 1) AND (Group.Count < MIN_TROOPS_IN_GROUP)) then
|
||||
Continue;
|
||||
// Add grop pointer to array (but dont increase count now so it will be ignored)
|
||||
AG.GroupArr[AG.Count] := Group;
|
||||
// Check if group can be in array
|
||||
if (aMobilizationCoef = 1) then
|
||||
begin
|
||||
// Take all groups out of attack class
|
||||
if not fAttackNew.IsGroupInAction(Group) then
|
||||
Inc(AG.Count,1); // Confirm that the group should be in array GroupArr
|
||||
end
|
||||
else
|
||||
begin
|
||||
// Take group in defence position if it is required by mobilization
|
||||
DP := fDefence.FindPositionOf(Group, KaMRandom({$IFDEF DBG_RNG_SPY}'TKMArmyManagement.RecruitSoldiers'{$ENDIF}) < aMobilizationCoef ); // True = First line will not be considered
|
||||
if (DP <> nil) then
|
||||
Inc(AG.Count,1); // Confirm that the group should be in array GroupArr
|
||||
end;
|
||||
end;
|
||||
FillChar(AG.GroupsAvailable, SizeOf(AG.GroupsAvailable), #0);
|
||||
FillChar(AG.MenAvailable, SizeOf(AG.MenAvailable), #0);
|
||||
for K := 0 to AG.Count - 1 do
|
||||
begin
|
||||
Group := AG.GroupArr[K];
|
||||
Inc(AG.GroupsAvailable[ Group.GroupType ]);
|
||||
Inc(AG.MenAvailable[ Group.GroupType ],Group.Count);
|
||||
end;
|
||||
Result := AG;
|
||||
end;
|
||||
// Filter groups
|
||||
procedure FilterGroups(aTotalMen: Integer; aGroupAmounts: TKMGroupTypeArray; var aAG: TKMAvailableGroups);
|
||||
var
|
||||
GCnt, MenCnt, StartIdx, ActIdx: Integer;
|
||||
G: TKMUnitGroup;
|
||||
GT: TKMGroupType;
|
||||
begin
|
||||
if (aTotalMen = 0) then
|
||||
Exit;
|
||||
// Select the right number of groups
|
||||
StartIdx := 0;
|
||||
MenCnt := 0;
|
||||
for GT := GROUP_TYPE_MIN to GROUP_TYPE_MAX do
|
||||
begin
|
||||
GCnt := aGroupAmounts[GT];
|
||||
ActIdx := StartIdx;
|
||||
while (GCnt > 0) AND (ActIdx < aAG.Count) do
|
||||
begin
|
||||
if (aAG.GroupArr[ActIdx].GroupType = GT) then
|
||||
begin
|
||||
G := aAG.GroupArr[StartIdx];
|
||||
aAG.GroupArr[StartIdx] := aAG.GroupArr[ActIdx];
|
||||
aAG.GroupArr[ActIdx] := G;
|
||||
Inc(MenCnt, aAG.GroupArr[ActIdx].Count);
|
||||
Inc(StartIdx);
|
||||
Dec(GCnt);
|
||||
end;
|
||||
Inc(ActIdx);
|
||||
end;
|
||||
end;
|
||||
// Add another groups if we dont have enough men
|
||||
while (MenCnt < aTotalMen) AND (ActIdx < aAG.Count) do
|
||||
begin
|
||||
Inc(MenCnt, aAG.GroupArr[ActIdx].Count);
|
||||
Inc(ActIdx);
|
||||
end;
|
||||
aAG.Count := ActIdx;
|
||||
SetLength(aAG.GroupArr, ActIdx);
|
||||
end;
|
||||
|
||||
function FindScriptedTarget(aGroup: TKMUnitGroup; aTarget: TKMAIAttackTarget; aCustomPos: TKMPoint; var aTargetP: TKMPoint ): Boolean;
|
||||
var
|
||||
TargetHouse: TKMHouse;
|
||||
TargetUnit: TKMUnit;
|
||||
begin
|
||||
aTargetP := KMPOINT_ZERO;
|
||||
TargetHouse := nil;
|
||||
TargetUnit := nil;
|
||||
//Find target
|
||||
case aTarget of
|
||||
attClosestUnit: TargetUnit := gHands.GetClosestUnit(aGroup.Position, fOwner, atEnemy);
|
||||
attClosestBuildingFromArmy: TargetHouse := gHands.GetClosestHouse(aGroup.Position, fOwner, atEnemy, TARGET_HOUSES, False);
|
||||
attClosestBuildingFromStartPos: TargetHouse := gHands.GetClosestHouse(fSetup.StartPosition, fOwner, atEnemy, TARGET_HOUSES, False);
|
||||
attCustomPosition:
|
||||
begin
|
||||
TargetHouse := gHands.HousesHitTest(aCustomPos.X, aCustomPos.Y);
|
||||
if (TargetHouse <> nil) AND (gHands.CheckAlliance(fOwner, TargetHouse.Owner) = atAlly) then
|
||||
TargetHouse := nil;
|
||||
TargetUnit := gTerrain.UnitsHitTest(aCustomPos.X, aCustomPos.Y);
|
||||
if (TargetUnit <> nil) AND ((gHands.CheckAlliance(fOwner, TargetUnit.Owner) = atAlly) OR TargetUnit.IsDeadOrDying) then
|
||||
TargetUnit := nil;
|
||||
end;
|
||||
end;
|
||||
//Choose best option
|
||||
if (TargetHouse <> nil) then
|
||||
aTargetP := TargetHouse.Position
|
||||
else if (TargetUnit <> nil) then
|
||||
aTargetP := TargetUnit.Position
|
||||
else if (aTarget = attCustomPosition) then
|
||||
aTargetP := aCustomPos;
|
||||
Result := not KMSamePoint(aTargetP, KMPOINT_ZERO);
|
||||
end;
|
||||
|
||||
// Order attack by releasing Defensive groups and creating Combat groups
|
||||
procedure OrderAttack(aTargetPoint: TKMPoint; var aAG: TKMAvailableGroups);
|
||||
var
|
||||
K: Integer;
|
||||
begin
|
||||
for K := 0 to aAG.Count - 1 do
|
||||
fDefence.ReleaseGroup(aAG.GroupArr[K]);
|
||||
|
||||
fAttackNew.AddGroups(aAG.GroupArr);
|
||||
//fAttackNew.AddGroups( fDefence.ReleaseAllGroups );
|
||||
end;
|
||||
const
|
||||
MIN_DEF_RATIO = 1.2;
|
||||
ATT_ADVANTAGE = 0.2;
|
||||
MIN_BEST_ALLI_CMP = 0.8;
|
||||
MIN_WORST_ALLI_CMP = 0.5;
|
||||
MIN_GROUPS_IN_ATTACK = 4;
|
||||
var
|
||||
K: Integer;
|
||||
DefRatio, MobilizationCoef: Single;
|
||||
TargetPoint: TKMPoint;
|
||||
AG: TKMAvailableGroups;
|
||||
begin
|
||||
if fAttackRequest.Active then
|
||||
begin
|
||||
fAttackRequest.Active := False;
|
||||
// Check defences and comparison of strength
|
||||
DefRatio := fDefence.DefenceStatus;
|
||||
with fAttackRequest do
|
||||
begin
|
||||
// Exit if AI has NOT enough soldiers for defences in the FFA mode
|
||||
if FFA AND not FoodShortage AND (DefRatio < MIN_DEF_RATIO) AND (gGameParams.MissionMode <> mmFighting) then
|
||||
Exit;
|
||||
// 1v1 or special game mode
|
||||
if not FFA OR gGameParams.IsTactic then
|
||||
MobilizationCoef := 1
|
||||
// Else compute if it is necessary to mobilize the first defence line (or fraction)
|
||||
else
|
||||
begin
|
||||
// Relative def ratio
|
||||
DefRatio := Max( 0, (DefRatio - 1) / Max(1, DefRatio) ); // = <0,1); 0 = army is in the first line of def. pos.; 1 = army is in second lines
|
||||
// Mobilization of the first line // * (WorstAllianceCmp)
|
||||
MobilizationCoef := Min(1, (1+ATT_ADVANTAGE) / (1+BestAllianceCmp) ) * (1 - DefRatio);
|
||||
end;
|
||||
end;
|
||||
// Get array of pointers to available groups
|
||||
AG := GetGroups(MobilizationCoef);
|
||||
// If we dont have enough groups then exit (if we should take all check if there are already some combat groups)
|
||||
if (MobilizationCoef < 1) AND (AG.Count < MIN_GROUPS_IN_ATTACK) then
|
||||
Exit;
|
||||
// Order attack
|
||||
OrderAttack(TargetPoint, AG);
|
||||
end
|
||||
else if not fSetup.AutoAttack then
|
||||
with gHands[fOwner].AI.General do
|
||||
begin
|
||||
AG := GetGroups(1);
|
||||
for K := 0 to Attacks.Count - 1 do
|
||||
if Attacks.CanOccur(K, AG.MenAvailable, AG.GroupsAvailable, gGameParams.Tick) then //Check conditions are right
|
||||
begin
|
||||
FilterGroups(Attacks[K].TotalMen, Attacks[K].GroupAmounts, AG);
|
||||
if FindScriptedTarget(AG.GroupArr[0], Attacks[K].Target, Attacks[K].CustomPosition, TargetPoint) then
|
||||
begin
|
||||
OrderAttack(TargetPoint,AG);
|
||||
Attacks.HasOccured(K);
|
||||
break; // Just 1 attack in 1 tick
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyManagement.SetAttackRequest(aAttackRequest: TKMAttackRequest);
|
||||
begin
|
||||
fAttackRequest.Active := aAttackRequest.Active;
|
||||
fAttackRequest.FFA := aAttackRequest.FFA;
|
||||
fAttackRequest.FoodShortage := aAttackRequest.FoodShortage;
|
||||
fAttackRequest.BestAllianceCmp := aAttackRequest.BestAllianceCmp;
|
||||
fAttackRequest.WorstAllianceCmp := aAttackRequest.WorstAllianceCmp;
|
||||
fAttackRequest.BestEnemy := aAttackRequest.BestEnemy;
|
||||
SetLength(fAttackRequest.Enemies, Length(aAttackRequest.Enemies) );
|
||||
Move(aAttackRequest.Enemies[0], fAttackRequest.Enemies[0], SizeOf(fAttackRequest.Enemies[0])*Length(fAttackRequest.Enemies));
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyManagement.UpdateState(aTick: Cardinal);
|
||||
begin
|
||||
{$IFDEF DBG_PERFLOG}
|
||||
gPerfLogs.SectionEnter(psAIArmyAdv);
|
||||
{$ENDIF}
|
||||
try
|
||||
if (aTick mod MAX_HANDS = fOwner) then
|
||||
begin
|
||||
if not gGame.IsPeaceTime then
|
||||
begin
|
||||
CheckAttack;
|
||||
RecruitSoldiers;
|
||||
end;
|
||||
CheckGroupsState;
|
||||
fAttackNew.UpdateState(aTick);
|
||||
fDefence.UpdateState(aTick);
|
||||
end;
|
||||
finally
|
||||
{$IFDEF DBG_PERFLOG}
|
||||
gPerfLogs.SectionLeave(psAIArmyAdv);
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMArmyManagement.CombineBalanceStrings: UnicodeString;
|
||||
begin
|
||||
Result := fBalanceText;
|
||||
fAttackNew.LogStatus(Result);
|
||||
fDefence.LogStatus(Result);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMArmyManagement.Paint;
|
||||
begin
|
||||
fAttackNew.Paint;
|
||||
fDefence.Paint;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
+2391
File diff suppressed because it is too large.
Load diff
+1131
File diff suppressed because it is too large.
Load diff
+3605
File diff suppressed because it is too large.
Load diff
+911
@@ -0,0 +1,911 @@
|
||||
{
|
||||
Artificial intelligence
|
||||
@author: Martin Toupal
|
||||
@e-mail: poznamenany@gmail.com
|
||||
}
|
||||
unit KM_CityPredictor;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
SysUtils, Classes, Math,
|
||||
KromUtils,
|
||||
KM_Defaults, KM_CommonClasses, KM_CommonTypes,
|
||||
KM_AISetup, KM_ResHouses, KM_ResWares, KM_HandStats, KM_AIParameters,
|
||||
KM_ResTypes;
|
||||
|
||||
type
|
||||
TWareBalance = record
|
||||
Production, ActualConsumption, FinalConsumption, Exhaustion, Fraction: Single;
|
||||
end;
|
||||
// Information about city (it can be replaced by player's stats but it doesnt allow prediction with different values)
|
||||
TCityStats = record
|
||||
CitizensCnt, WarriorsCnt, HousesCnt: Integer;
|
||||
Citizens: array[CITIZEN_MIN..CITIZEN_MAX] of Integer; // Stats sometimes throw negative number in case of Recruit so keep integer
|
||||
Warriors: array[WARRIOR_MIN..WARRIOR_MAX] of Integer;
|
||||
Houses: array[HOUSE_MIN..HOUSE_MAX] of Integer;
|
||||
end;
|
||||
THouseBuildHistory = record
|
||||
Count: Word;
|
||||
Quantity: TKMWordArray;
|
||||
Tick: TKMCardinalArray;
|
||||
end;
|
||||
TWareBalanceArray = array[WARE_MIN..WARE_MAX] of TWareBalance;
|
||||
//TWarfareDemands = array[WARFARE_MIN..WARFARE_MAX] of Single;
|
||||
TRequiredHousesArray = array[HOUSE_MIN..HOUSE_MAX] of Integer;
|
||||
|
||||
// City predictor (calculation of required houses based on prediction of resource flow)
|
||||
TKMCityPredictor = class
|
||||
private
|
||||
fOwner: TKMHandID;
|
||||
fCityStats: TCityStats;
|
||||
fCityUnderConstruction, fCityCompleted: Boolean;
|
||||
fWorkerCount: Word;
|
||||
fMaxGoldMineCnt, fDecCoalMineCnt, fIronMineCnt, fFieldCnt, fBuildCnt: Integer;
|
||||
fMaxIronWeapProd, fMaxWoodWeapProd, fMaxSoldiersInMin, fPeaceFactor, fUpdatedPeaceFactor: Single;
|
||||
fWareBalance: TWareBalanceArray;
|
||||
fFarmBuildHistory: THouseBuildHistory; // Farms are another exception in production (production is delayed and depends on position of each farm)
|
||||
fSetup: TKMHandAISetup;
|
||||
|
||||
procedure UpdateWareProduction(aWT: TKMWareType);
|
||||
procedure UpdateWareConsumption(aWT: TKMWareType; aInitialization: Boolean = False);
|
||||
procedure UpdateFoodConsumption(aInitialization: Boolean = False);
|
||||
procedure UpdateGoldConsumption(aInitialization: Boolean = False);
|
||||
procedure UpdateBuildMaterialConsumption(aInitialization: Boolean = False);
|
||||
procedure UpdateWareDerivation(aWT: TKMWareType; aInitialization: Boolean = False);
|
||||
procedure UpdateWareBalance(aInitialization: Boolean = False);
|
||||
|
||||
procedure UpdateBasicHouses(aTick: Cardinal; aInitialization: Boolean = False);
|
||||
procedure UpdateFinalProduction(aIncPeaceFactor: Single = 0; aIncrementMines: Boolean = False);
|
||||
procedure UpdateCityStats();
|
||||
|
||||
procedure FilterRequiredHouses(aTick: Cardinal);
|
||||
public
|
||||
RequiredHouses: TRequiredHousesArray;
|
||||
|
||||
constructor Create(aPlayer: TKMHandID; aSetup: TKMHandAISetup);
|
||||
destructor Destroy(); override;
|
||||
procedure Save(SaveStream: TKMemoryStream);
|
||||
procedure Load(LoadStream: TKMemoryStream);
|
||||
|
||||
property UpdatedPeaceFactor: Single read fUpdatedPeaceFactor;
|
||||
property CityStats: TCityStats read fCityStats;
|
||||
property CityCompleted: Boolean read fCityCompleted;
|
||||
property WareBalance: TWareBalanceArray read fWareBalance;
|
||||
property WorkerCount: Word read fWorkerCount;
|
||||
property MaxGoldMineCnt: Integer read fMaxGoldMineCnt write fMaxGoldMineCnt;
|
||||
property IronMineCnt: Integer read fIronMineCnt write fIronMineCnt;
|
||||
property FieldCnt: Integer read fFieldCnt write fFieldCnt;
|
||||
property BuildCnt: Integer read fBuildCnt write fBuildCnt;
|
||||
|
||||
procedure AfterMissionInit();
|
||||
procedure UpdateState(aTick: Cardinal);
|
||||
procedure LogStatus(var aBalanceText: UnicodeString);
|
||||
procedure OwnerUpdate(aPlayer: TKMHandID);
|
||||
procedure MarkExhaustedMine(aMineType: TKMHouseType);
|
||||
|
||||
end;
|
||||
|
||||
const
|
||||
|
||||
{
|
||||
TKMWareType:
|
||||
wtNone,
|
||||
wtTrunk, wtStone, wtWood, wtIronOre, wtGoldOre,
|
||||
wtCoal, wtSteel, wtGold, wtWine, wtCorn,
|
||||
wtBread, wtFlour, wtLeather, wtSausages, wtPig,
|
||||
wtSkin, wtShield, wtMetalShield, wtArmor, wtMetalArmor,
|
||||
wtAxe, wtSword, wtPike, wtHallebard, wtBow,
|
||||
wtArbalet, wtHorse, wtFish,
|
||||
wtAll, wtWarfare, wtFood
|
||||
}
|
||||
// Array of wares which are produced by specific houses
|
||||
PRODUCTION_WARE2HOUSE: array[WARE_MIN..WARE_MAX] of TKMHouseType = (
|
||||
htWoodcutters, htQuarry, htSawmill, htIronMine, htGoldMine,
|
||||
htCoalMine, htIronSmithy, htMetallurgists, htVineyard, htFarm,
|
||||
htBakery, htMill, htTannery, htButchers, htSwine,
|
||||
htSwine, htArmorWorkshop, htArmorSmithy, htArmorWorkshop, htArmorSmithy,
|
||||
htWeaponWorkshop, htWeaponSmithy, htWeaponWorkshop, htWeaponSmithy, htWeaponWorkshop,
|
||||
htWeaponSmithy, htStables, htFishermans
|
||||
);
|
||||
// Possible transformation of wares: resource -> product
|
||||
CONSUMPTION_WARE: array[WARE_MIN..WARE_MAX] of array[0..3] of TKMWareType = ( // wtShield are ignored
|
||||
(wtTimber, wtNone, wtNone, wtNone), (wtNone, wtNone, wtNone, wtNone), (wtAxe, wtNone, wtNone, wtNone), (wtIron, wtNone, wtNone, wtNone), (wtGold, wtNone, wtNone, wtNone),
|
||||
(wtIron, wtGold, wtIronArmor, wtSword), (wtIronArmor, wtSword, wtNone, wtNone), (wtNone, wtNone, wtNone, wtNone), (wtNone, wtNone, wtNone, wtNone), (wtFlour, wtPig, wtHorse, wtNone),
|
||||
(wtNone, wtNone, wtNone, wtNone), (wtBread, wtNone, wtNone, wtNone), (wtLeatherArmor, wtNone, wtNone, wtNone), (wtNone, wtNone, wtNone, wtNone), (wtSausage, wtNone, wtNone, wtNone),
|
||||
(wtLeather, wtNone, wtNone, wtNone), (wtNone, wtNone, wtNone, wtNone), (wtNone, wtNone, wtNone, wtNone), (wtNone, wtNone, wtNone, wtNone), (wtNone, wtNone, wtNone, wtNone),
|
||||
(wtNone, wtNone, wtNone, wtNone), (wtNone, wtNone, wtNone, wtNone), (wtNone, wtNone, wtNone, wtNone), (wtNone, wtNone, wtNone, wtNone), (wtNone, wtNone, wtNone, wtNone),
|
||||
(wtNone, wtNone, wtNone, wtNone), (wtNone, wtNone, wtNone, wtNone), (wtNone, wtNone, wtNone, wtNone)
|
||||
);
|
||||
// Array of wares which are consumed in specific amount to achieve specific production (because of exceptions in htWeaponWorkshop / htSwine / htStables etc.)
|
||||
CONSUMPTION_RATIO: array[wtTrunk..wtSkin] of array[0..3] of Single = (
|
||||
// 1 trunk = 2 Wood 2 wood = 1 axe/bow/spear 1 GoldOre = 2 Gold (+ 1 Coal)
|
||||
(0.5, 1, 1, 1), (1, 1, 1, 1), (2, 1, 1, 1), (1, 1, 1, 1), (0.5, 1, 1, 1),
|
||||
// 1 coal = 2 gold (+ 1 gold ore) BEAST_COST = 4 (per a pig / horse)
|
||||
(0.5, 1, 1, 1), (1, 1, 1, 1), (1, 1, 1, 1), (1, 1, 1, 1), (1, 4, 4, 1),
|
||||
// 1 flour = 2 bread 1 pig = 3 sausages
|
||||
(1, 1, 1, 1), (0.5, 1, 1, 1), (1, 1, 1, 1), (1, 1, 1, 1), (0.333, 1, 1, 1),
|
||||
// 1 skin = 2 leather
|
||||
(0.5, 1, 1, 1)
|
||||
);
|
||||
CONSUMPTION_ORDER: array[0..27] of TKMWareType = ( // Basicaly TKMWareType but sorted by order: resource -> product
|
||||
wtStone, wtTrunk, wtTimber,
|
||||
wtCorn, wtFlour, wtBread, wtWine, wtFish,
|
||||
wtPig, wtSausage, wtSkin, wtLeather, wtHorse,
|
||||
wtGoldOre, wtIronOre, wtCoal, wtGold, wtIron,
|
||||
wtAxe, wtBow, wtLance, wtLeatherArmor, wtWoodenShield,
|
||||
wtSword, wtCrossbow, wtPike, wtIronShield, wtIronArmor
|
||||
);
|
||||
CO_WEAPONS_MIN = 18;
|
||||
CO_WEAPONS_MAX = 27;
|
||||
CO_IRON_WEAPONS_MIN = 23;
|
||||
CO_IRON_WEAPONS_MAX = 27;
|
||||
CO_WOOD_WEAPONS_MIN = 22;
|
||||
CO_WOOD_WEAPONS_MAX = 18;
|
||||
CO_WARE_MIN = 0;
|
||||
CO_WARE_MAX = 17;
|
||||
{
|
||||
// Array of wares which are consumed by specific houses
|
||||
CONSUMPTION_WARE: array[WARE_MIN..WARE_MAX] of array[0..3] of TKMHouseType = (
|
||||
(htSawmill, htNone, htNone, htNone), (htNone, htNone, htNone, htNone), (htWeaponWorkshop, htArmorWorkshop, htNone, htNone), (htIronSmithy, htNone, htNone, htNone), (htMetallurgists, htNone, htNone, htNone),
|
||||
(htMetallurgists, htIronSmithy, htArmorSmithy, htWeaponSmithy), (htArmorSmithy, htWeaponSmithy, htNone, htNone), (htNone, htNone, htNone, htNone), (htNone, htNone, htNone, htNone), (htMill, htSwine, htStables, htNone),
|
||||
(htNone, htNone, htNone, htNone), (htBakery, htNone, htNone, htNone), (htArmorWorkshop, htNone, htNone, htNone), (htNone, htNone, htNone, htNone), (htButchers, htNone, htNone, htNone),
|
||||
(htTannery, htNone, htNone, htNone), (htNone, htNone, htNone, htNone), (htNone, htNone, htNone, htNone), (htNone, htNone, htNone, htNone), (htNone, htNone, htNone, htNone),
|
||||
(htNone, htNone, htNone, htNone), (htNone, htNone, htNone, htNone), (htNone, htNone, htNone, htNone), (htNone, htNone, htNone, htNone), (htNone, htNone, htNone, htNone),
|
||||
(htNone, htNone, htNone, htNone), (htNone, htNone, htNone, htNone), (htNone, htNone, htNone, htNone)
|
||||
);
|
||||
}
|
||||
|
||||
implementation
|
||||
uses
|
||||
KM_HandsCollection, KM_Hand, KM_Game, KM_GameParams, KM_CityPlanner;
|
||||
|
||||
|
||||
{ TKMCityPredictor }
|
||||
constructor TKMCityPredictor.Create(aPlayer: TKMHandID; aSetup: TKMHandAISetup);
|
||||
begin
|
||||
inherited Create;
|
||||
fOwner := aPlayer;
|
||||
fSetup := aSetup;
|
||||
fWorkerCount := 0;
|
||||
fCityUnderConstruction := False;
|
||||
fCityCompleted := False;
|
||||
|
||||
fMaxGoldMineCnt := 0;
|
||||
fDecCoalMineCnt := 0;
|
||||
fIronMineCnt := 0;
|
||||
fFieldCnt := 0;
|
||||
fBuildCnt := 0;
|
||||
|
||||
fMaxIronWeapProd := 0;
|
||||
fMaxWoodWeapProd := 0;
|
||||
fMaxSoldiersInMin := 0;
|
||||
fPeaceFactor := 0;
|
||||
fUpdatedPeaceFactor := 0;
|
||||
|
||||
with fFarmBuildHistory do
|
||||
begin
|
||||
Count := 1;
|
||||
SetLength(Quantity,1);
|
||||
SetLength(Tick,1);
|
||||
Quantity[0] := 0;
|
||||
Tick[0] := 10 * 60 * 10; // Init delay 10 min
|
||||
end;
|
||||
end;
|
||||
|
||||
destructor TKMCityPredictor.Destroy();
|
||||
begin
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCityPredictor.Save(SaveStream: TKMemoryStream);
|
||||
var
|
||||
WT: TKMWareType;
|
||||
begin
|
||||
SaveStream.PlaceMarker('CityPredictor');
|
||||
SaveStream.Write(fOwner);
|
||||
SaveStream.Write(fWorkerCount);
|
||||
SaveStream.Write(fCityUnderConstruction);
|
||||
SaveStream.Write(fCityCompleted);
|
||||
|
||||
|
||||
SaveStream.Write(fMaxGoldMineCnt);
|
||||
SaveStream.Write(fDecCoalMineCnt);
|
||||
SaveStream.Write(fIronMineCnt);
|
||||
SaveStream.Write(fFieldCnt);
|
||||
SaveStream.Write(fBuildCnt);
|
||||
|
||||
SaveStream.Write(fMaxIronWeapProd);
|
||||
SaveStream.Write(fMaxWoodWeapProd);
|
||||
SaveStream.Write(fMaxSoldiersInMin);
|
||||
SaveStream.Write(fPeaceFactor);
|
||||
SaveStream.Write(fUpdatedPeaceFactor);
|
||||
|
||||
SaveStream.Write(fFarmBuildHistory.Count);
|
||||
if (fFarmBuildHistory.Count > 0) then
|
||||
begin
|
||||
SaveStream.Write(fFarmBuildHistory.Quantity[0], SizeOf(fFarmBuildHistory.Quantity[0]) * fFarmBuildHistory.Count);
|
||||
SaveStream.Write(fFarmBuildHistory.Tick[0], SizeOf(fFarmBuildHistory.Tick[0]) * fFarmBuildHistory.Count);
|
||||
end;
|
||||
|
||||
// Requred houses should be saved because of public variable
|
||||
SaveStream.Write(RequiredHouses, SizeOf(TRequiredHousesArray));
|
||||
// fWareBalance must be saved because of FinalConsumption, Trading and building algorithm
|
||||
for WT := WARE_MIN to WARE_MAX do
|
||||
SaveStream.Write(fWareBalance[WT], SizeOf(TWareBalance));
|
||||
// Stats are updated each cycle and doesn't have to be saved
|
||||
//fCityStats: TCityStats;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCityPredictor.Load(LoadStream: TKMemoryStream);
|
||||
var
|
||||
WT: TKMWareType;
|
||||
begin
|
||||
LoadStream.CheckMarker('CityPredictor');
|
||||
LoadStream.Read(fOwner);
|
||||
LoadStream.Read(fWorkerCount);
|
||||
LoadStream.Read(fCityUnderConstruction);
|
||||
LoadStream.Read(fCityCompleted);
|
||||
|
||||
LoadStream.Read(fMaxGoldMineCnt);
|
||||
LoadStream.Read(fDecCoalMineCnt);
|
||||
LoadStream.Read(fIronMineCnt);
|
||||
LoadStream.Read(fFieldCnt);
|
||||
LoadStream.Read(fBuildCnt);
|
||||
|
||||
LoadStream.Read(fMaxIronWeapProd);
|
||||
LoadStream.Read(fMaxWoodWeapProd);
|
||||
LoadStream.Read(fMaxSoldiersInMin);
|
||||
LoadStream.Read(fPeaceFactor);
|
||||
LoadStream.Read(fUpdatedPeaceFactor);
|
||||
|
||||
LoadStream.Read(fFarmBuildHistory.Count);
|
||||
if (fFarmBuildHistory.Count > 0) then
|
||||
begin
|
||||
SetLength(fFarmBuildHistory.Quantity, fFarmBuildHistory.Count);
|
||||
SetLength(fFarmBuildHistory.Tick, fFarmBuildHistory.Count);
|
||||
LoadStream.Read(fFarmBuildHistory.Quantity[0], SizeOf(fFarmBuildHistory.Quantity[0]) * fFarmBuildHistory.Count);
|
||||
LoadStream.Read(fFarmBuildHistory.Tick[0], SizeOf(fFarmBuildHistory.Tick[0]) * fFarmBuildHistory.Count);
|
||||
end;
|
||||
|
||||
// Requred houses should be saved because of public variable
|
||||
LoadStream.Read(RequiredHouses, SizeOf(TRequiredHousesArray));
|
||||
// fWareBalance must be saved because of FinalConsumption
|
||||
for WT := WARE_MIN to WARE_MAX do
|
||||
LoadStream.Read(fWareBalance[WT], SizeOf(TWareBalance));
|
||||
// Stats are updated each cycle and doesn't have to be saved
|
||||
//fCityStats: TCityStats;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCityPredictor.OwnerUpdate(aPlayer: TKMHandID);
|
||||
begin
|
||||
fOwner := aPlayer;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCityPredictor.MarkExhaustedMine(aMineType: TKMHouseType);
|
||||
begin
|
||||
case aMineType of
|
||||
htIronMine: Dec(fIronMineCnt);
|
||||
htGoldMine: Dec(fMaxGoldMineCnt);
|
||||
htCoalMine: Inc(fDecCoalMineCnt);
|
||||
end;
|
||||
UpdateFinalProduction();
|
||||
end;
|
||||
|
||||
|
||||
// Update ware production
|
||||
procedure TKMCityPredictor.UpdateWareProduction(aWT: TKMWareType);
|
||||
begin
|
||||
fWareBalance[aWT].Production := fCityStats.Houses[ PRODUCTION_WARE2HOUSE[aWT] ] * PRODUCTION_RATE[aWT];
|
||||
end;
|
||||
|
||||
|
||||
// Update ware consumption
|
||||
procedure TKMCityPredictor.UpdateWareConsumption(aWT: TKMWareType; aInitialization: Boolean = False);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
fWareBalance[aWT].ActualConsumption := 0;
|
||||
if aInitialization then
|
||||
fWareBalance[aWT].FinalConsumption := 0;
|
||||
for I := Low(CONSUMPTION_WARE[aWT]) to High(CONSUMPTION_WARE[aWT]) do
|
||||
if (CONSUMPTION_WARE[aWT,I] <> wtNone) then
|
||||
begin
|
||||
fWareBalance[aWT].ActualConsumption := fWareBalance[aWT].ActualConsumption + fWareBalance[ CONSUMPTION_WARE[aWT,I] ].ActualConsumption * CONSUMPTION_RATIO[aWT,I];
|
||||
if aInitialization then
|
||||
fWareBalance[aWT].FinalConsumption := fWareBalance[aWT].FinalConsumption + Max(fWareBalance[ CONSUMPTION_WARE[aWT,I] ].FinalConsumption, fWareBalance[ CONSUMPTION_WARE[aWT,I] ].ActualConsumption) * CONSUMPTION_RATIO[aWT,I];
|
||||
end
|
||||
else
|
||||
break;
|
||||
end;
|
||||
|
||||
|
||||
// Update food consumption
|
||||
procedure TKMCityPredictor.UpdateFoodConsumption(aInitialization: Boolean = False);
|
||||
const
|
||||
CITIZEN_FOOD_COEF = 0.05; // On average citizen needs to eat each 40min but takes 2 food to full status = 1/20 = 0.05
|
||||
SOLDIER_FOOD_COEF = 0.025; // On average soldier needs to eat each 40min and takes 1 food to full status = 1/40 = 0.025
|
||||
var
|
||||
Consumption: Single;
|
||||
begin
|
||||
// Get consumption of city + army
|
||||
Consumption := (fCityStats.CitizensCnt * CITIZEN_FOOD_COEF) + (fCityStats.WarriorsCnt * SOLDIER_FOOD_COEF);
|
||||
// Calculate consumption of leather armor / minute and pigs which are produced with this cycle
|
||||
// 2x armor = 2x leather = 1x skin = 1x pig = 3x sausages ... sausages = 3 / 2 * armor = 1.5 * armor
|
||||
fWareBalance[wtSausage].ActualConsumption := Min(Consumption, fWareBalance[wtLeatherArmor].FinalConsumption * 1.5);
|
||||
// Split rest of consumtion into other houses
|
||||
Consumption := Max(0, Consumption - fWareBalance[wtSausage].ActualConsumption);
|
||||
fWareBalance[wtBread].ActualConsumption := Consumption * 0.7;
|
||||
fWareBalance[wtWine].ActualConsumption := Consumption * 0.3;
|
||||
fWareBalance[wtFish].ActualConsumption := 0;
|
||||
// Expected food consumption of the final city size (it helps with build order to secure food and weapons production ASAP)
|
||||
if aInitialization then
|
||||
begin
|
||||
fWareBalance[wtSausage].FinalConsumption := fWareBalance[wtSausage].ActualConsumption;
|
||||
fWareBalance[wtBread].FinalConsumption := fWareBalance[wtBread].ActualConsumption;
|
||||
fWareBalance[wtWine].FinalConsumption := fWareBalance[wtWine].ActualConsumption;
|
||||
fWareBalance[wtFish].FinalConsumption := fWareBalance[wtFish].ActualConsumption;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
// Update gold consumption
|
||||
procedure TKMCityPredictor.UpdateGoldConsumption(aInitialization: Boolean = False);
|
||||
const
|
||||
GOLD_NEED_PER_A_SCHOOL = 3.5; // Amount of gold which requires school (in 1 minute)
|
||||
begin
|
||||
fWareBalance[wtGold].ActualConsumption := Min(fMaxSoldiersInMin, (fCityStats.Houses[htSchool] + RequiredHouses[htSchool]) * GOLD_NEED_PER_A_SCHOOL);
|
||||
end;
|
||||
|
||||
|
||||
// Update build material consumption
|
||||
procedure TKMCityPredictor.UpdateBuildMaterialConsumption(aInitialization: Boolean = False);
|
||||
begin
|
||||
// Worker count is decreased after peace time -> compute with maximal count
|
||||
fWareBalance[wtStone].ActualConsumption := Min(fCityStats.Citizens[utBuilder] + Round(AI_Par[PREDICTOR_WareNeedPerAWorker_StoneOffset]), fWorkerCount) * AI_Par[PREDICTOR_WareNeedPerAWorker_Stone];
|
||||
fWareBalance[wtStone].FinalConsumption := fWareBalance[wtStone].ActualConsumption;
|
||||
// Raw wood expectations
|
||||
UpdateWareConsumption(wtTimber, aInitialization);
|
||||
fWareBalance[wtTimber].ActualConsumption := Max(fWareBalance[wtTimber].ActualConsumption, fCityStats.Citizens[utBuilder] * AI_Par[PREDICTOR_WareNeedPerAWorker_Wood]);
|
||||
fWareBalance[wtTimber].FinalConsumption := Max(fWareBalance[wtTimber].FinalConsumption, fWorkerCount * AI_Par[PREDICTOR_WareNeedPerAWorker_Wood]);
|
||||
end;
|
||||
|
||||
|
||||
// Update ware derivation - 2 views:
|
||||
// 1. Exhaustion = estimation of time when will be ware depleted (determine which house should be built at first)
|
||||
// 2. Fraction = fraction of required and available houses
|
||||
procedure TKMCityPredictor.UpdateWareDerivation(aWT: TKMWareType; aInitialization: Boolean = False);
|
||||
function GetDependentWareBalance(): Single;
|
||||
begin
|
||||
Result := gHands[fOwner].Stats.GetWareBalance(aWT);
|
||||
case aWT of
|
||||
wtTrunk: Result := Result + gHands[fOwner].Stats.GetWareBalance(wtTimber) / 2;
|
||||
wtIronOre: Result := Result + gHands[fOwner].Stats.GetWareBalance(wtIron);
|
||||
//wtGoldOre: Result := Result + gHands[fOwner].Stats.GetWareBalance(wtGold) / 2;
|
||||
//wtCorn: Result := Result + gHands[fOwner].Stats.GetWareBalance(wtGold) / 2;
|
||||
wtFlour: Result := Result + gHands[fOwner].Stats.GetWareBalance(wtBread) / 2;
|
||||
wtPig: Result := Result + gHands[fOwner].Stats.GetWareBalance(wtSausage) / 3;
|
||||
wtSkin: Result := Result + gHands[fOwner].Stats.GetWareBalance(wtLeather) / 2;
|
||||
end;
|
||||
end;
|
||||
var
|
||||
houseReqCnt: Integer;
|
||||
HT: TKMHouseType;
|
||||
begin
|
||||
HT := PRODUCTION_WARE2HOUSE[aWT];
|
||||
with fWareBalance[aWT] do
|
||||
begin
|
||||
// Calculate when will be ware depleted
|
||||
Exhaustion := 999;
|
||||
if (ActualConsumption - Production > 0) then
|
||||
Exhaustion := Min( Exhaustion, GetDependentWareBalance() / (ActualConsumption - Production) );
|
||||
houseReqCnt := Ceil(( Max(ActualConsumption, FinalConsumption) - Production) / Max(0.0001, PRODUCTION_RATE[aWT]*1.0));
|
||||
if (houseReqCnt > 0) AND (Exhaustion >= 950) AND (fCityStats.Houses[ PRODUCTION_WARE2HOUSE[aWT] ] = 0) then
|
||||
houseReqCnt := 1
|
||||
else
|
||||
houseReqCnt := Byte(Exhaustion < 950) * houseReqCnt;
|
||||
Fraction := houseReqCnt / Max(1.0,((fCityStats.Houses[HT] + houseReqCnt)*1.0));
|
||||
end;
|
||||
RequiredHouses[HT] := houseReqCnt;
|
||||
end;
|
||||
|
||||
|
||||
// Update ware balance
|
||||
procedure TKMCityPredictor.UpdateWareBalance(aInitialization: Boolean = False);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
// Update weapons
|
||||
for I := CO_WEAPONS_MAX downto CO_WEAPONS_MIN do
|
||||
begin
|
||||
UpdateWareProduction(CONSUMPTION_ORDER[I]);
|
||||
// Final and actual consumptions for weapons are constant
|
||||
fWareBalance[ CONSUMPTION_ORDER[I] ].ActualConsumption := fWareBalance[ CONSUMPTION_ORDER[I] ].FinalConsumption;
|
||||
UpdateWareDerivation(CONSUMPTION_ORDER[I],aInitialization);
|
||||
end;
|
||||
|
||||
// Update "Normal" ware flow
|
||||
UpdateFoodConsumption(aInitialization);
|
||||
UpdateGoldConsumption(aInitialization);
|
||||
UpdateBuildMaterialConsumption(aInitialization);
|
||||
for I := CO_WARE_MAX downto CO_WARE_MIN do
|
||||
begin
|
||||
UpdateWareProduction(CONSUMPTION_ORDER[I]);
|
||||
// Exeptions
|
||||
case CONSUMPTION_ORDER[I] of
|
||||
// Food was updated at once
|
||||
wtWine, wtBread, wtSausage, wtFish: begin end;
|
||||
// Update Gold
|
||||
wtGold: begin end;
|
||||
// Update materials
|
||||
wtStone: begin end;
|
||||
wtTimber: begin end;
|
||||
// Other cases
|
||||
else
|
||||
UpdateWareConsumption(CONSUMPTION_ORDER[I], aInitialization);
|
||||
end;
|
||||
UpdateWareDerivation(CONSUMPTION_ORDER[I],aInitialization);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
// Basic house requirements
|
||||
procedure TKMCityPredictor.UpdateBasicHouses(aTick: Cardinal; aInitialization: Boolean = False);
|
||||
const
|
||||
INN_TIME_LIMIT = 60 * 10 * 14; // ~ 14 minutes from start
|
||||
SCHOOL_PRODUCTION = 3; // Amount of gold which requires school (in 1 minute) - in ideal case it requires only 3.5 in real there is not gold so it must be lower
|
||||
FIRST_MARKETPLACE = 10 * 60 * 60;
|
||||
SECOND_MARKETPLACE = 10 * 60 * 100;
|
||||
BARRACKS_PEACE_DELAY = 30; // Build barracks since 30 min
|
||||
BARRACKS_BEFORE_PEACE_END = 20; // Allow to build barracks before peace time end
|
||||
begin
|
||||
// 1 Storehouse
|
||||
RequiredHouses[htStore] := 1 - fCityStats.Houses[htStore];
|
||||
// 1 Barracks (build only when we have weapons and (from X tick or Y ticks before peace end -> avoid to build barracks in 1 minute when is still peace and we have predefined weapons in storehouse))
|
||||
RequiredHouses[htBarracks] := Byte(aInitialization OR ((gHands[fOwner].Stats.GetWareBalance(wtWarfare) > 0) AND ((aTick > BARRACKS_PEACE_DELAY * 600) OR (aTick > (gGame.Options.Peacetime - BARRACKS_BEFORE_PEACE_END) * 600)))) - fCityStats.Houses[htBarracks];
|
||||
// Schools (at least 1 + WarriorsPerMinute criterium)
|
||||
with gHands[fOwner].AI.CityManagement do
|
||||
RequiredHouses[htSchool] := Max(
|
||||
0,
|
||||
Max(
|
||||
1 + Byte( (RequiredUnitsCnt > Round(AI_Par[PREDICTOR_SecondSchool_MinRequiredUnits])) AND not Builder.GoldShortage AND not Builder.StoneShortage AND not Builder.TrunkShortage AND not Builder.WoodShortage),
|
||||
Byte( (fCityStats.Houses[htBarracks] > 0) OR aInitialization ) * (Ceil(fMaxSoldiersInMin / SCHOOL_PRODUCTION))
|
||||
) - fCityStats.Houses[htSchool]
|
||||
);
|
||||
// Inn (at least 1 after INN_TIME_LIMIT + CitizensCnt criterium)
|
||||
RequiredHouses[htInn] := Max(
|
||||
0,
|
||||
Ceil( Byte( (aTick > INN_TIME_LIMIT) OR aInitialization ) * fCityStats.CitizensCnt / 80 ) - fCityStats.Houses[htInn]
|
||||
);
|
||||
// Marketplace - 1. after FIRST_MARKETPLACE; 2. after SECOND_MARKETPLACE
|
||||
RequiredHouses[htMarket] := Byte( aInitialization OR (aTick > FIRST_MARKETPLACE) ) + Byte( aInitialization OR (aTick > SECOND_MARKETPLACE) ) - fCityStats.Houses[htMarket];
|
||||
end;
|
||||
|
||||
|
||||
// Get players stats and store them into local variable (to be able to edit them later)
|
||||
procedure TKMCityPredictor.UpdateCityStats();
|
||||
var
|
||||
constructedHouses: Integer;
|
||||
UT: TKMUnitType;
|
||||
HT: TKMHouseType;
|
||||
begin
|
||||
with fCityStats do
|
||||
begin
|
||||
CitizensCnt := 0;
|
||||
for UT := Low(Citizens) to High(Citizens) do
|
||||
begin
|
||||
Citizens[UT] := gHands[fOwner].Stats.GetUnitQty(UT);
|
||||
Inc(CitizensCnt, Citizens[UT]);
|
||||
end;
|
||||
Dec(CitizensCnt, Citizens[utRecruit]); // Count recruits as soldiers
|
||||
WarriorsCnt := Citizens[utRecruit];
|
||||
for UT := Low(Warriors) to High(Warriors) do
|
||||
begin
|
||||
Warriors[UT] := gHands[fOwner].Stats.GetUnitQty(UT);
|
||||
Inc(WarriorsCnt, Warriors[UT]);
|
||||
end;
|
||||
end;
|
||||
|
||||
constructedHouses := 0;
|
||||
fCityStats.HousesCnt := 0;
|
||||
with gHands[fOwner].AI.CityManagement.Builder do
|
||||
begin
|
||||
for HT := Low(fCityStats.Houses) to High(fCityStats.Houses) do
|
||||
begin
|
||||
//Houses[HT] := gHands[fOwner].Stats.GetHouseTotal(HT); // Does not consider planned houses
|
||||
// Consider only placed, constructed or planned houses (not destroyed houses because plans will remain in CityPlanner)
|
||||
fCityStats.Houses[HT] := Planner.PlannedHouses[HT].Completed + Planner.PlannedHouses[HT].UnderConstruction + Planner.PlannedHouses[HT].Planned;
|
||||
Inc(fCityStats.HousesCnt, fCityStats.Houses[HT]);
|
||||
Inc(constructedHouses, Planner.PlannedHouses[HT].UnderConstruction + Planner.PlannedHouses[HT].Planned);
|
||||
end;
|
||||
fCityUnderConstruction := (constructedHouses > 0) AND ((FreeWorkerCnt < 10) OR (constructedHouses > 3));
|
||||
fCityCompleted := (constructedHouses = 0) AND (FreeWorkerCnt = fCityStats.Citizens[utBuilder]);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCityPredictor.UpdateFinalProduction(aIncPeaceFactor: Single = 0; aIncrementMines: Boolean = False);
|
||||
const
|
||||
IRON_WARFARE: set of TKMWareType = [wtIronShield, wtIronArmor, wtSword, wtPike, wtCrossbow];
|
||||
WOOD_WARFARE: set of TKMWareType = [wtAxe, wtLance, wtBow];
|
||||
INV_AFTER_PEACE_SCALING = 1 / (30*10*60); // Peace factor will be completely removed after {30} mins since end of peace
|
||||
MIN_IRON_PRODUCTION = 2;
|
||||
MAX_IRON_PRODUCTION = 6;
|
||||
INV_REQUIRED_TILES_PER_IRON = 1/250;
|
||||
MIN_WOOD_PRODUCTION = 2;
|
||||
MAX_WOOD_PRODUCTION = 6;
|
||||
INV_REQUIRED_TILES_PER_WOOD = 1/450.0;
|
||||
TILE_RESERVE = 1000;
|
||||
IRON_RESERVE_COEF = 300;
|
||||
var
|
||||
maxIronWeapProd, maxWoodWeapProd, freePlace: Single;
|
||||
WT: TKMWareType;
|
||||
begin
|
||||
// Update peace factor
|
||||
fUpdatedPeaceFactor := Min(1,fUpdatedPeaceFactor + aIncPeaceFactor);
|
||||
// Consider available space around loc
|
||||
// Iron weapons - use only fixed peace factor because mines will run out anyway
|
||||
freePlace :=
|
||||
Max(
|
||||
0,
|
||||
(Min(fBuildCnt,2000) - TILE_RESERVE) * INV_REQUIRED_TILES_PER_IRON
|
||||
);
|
||||
maxIronWeapProd :=
|
||||
Min(
|
||||
Round(freePlace) + MIN_IRON_PRODUCTION,
|
||||
Min(
|
||||
MAX_IRON_PRODUCTION,
|
||||
fIronMineCnt + (gHands[fOwner].Stats.GetWareBalance(wtIronOre) + gHands[fOwner].Stats.GetWareBalance(wtIron)) / IRON_RESERVE_COEF
|
||||
)
|
||||
);
|
||||
// Wooden weapons
|
||||
freePlace :=
|
||||
Max(
|
||||
0,
|
||||
(Min(fFieldCnt,3000) - TILE_RESERVE) * INV_REQUIRED_TILES_PER_WOOD
|
||||
);
|
||||
maxWoodWeapProd :=
|
||||
Min(
|
||||
MAX_WOOD_PRODUCTION,
|
||||
Max( MIN_WOOD_PRODUCTION, Round(freePlace * fUpdatedPeaceFactor) )
|
||||
);
|
||||
// Consider Iron production
|
||||
maxWoodWeapProd :=
|
||||
Max(
|
||||
MIN_WOOD_PRODUCTION - Byte(maxIronWeapProd > 0),
|
||||
Round(maxWoodWeapProd - maxIronWeapProd * (1.0 - fUpdatedPeaceFactor) * 0.5)
|
||||
);
|
||||
|
||||
// Iron weapons
|
||||
maxIronWeapProd := maxIronWeapProd * PRODUCTION_RATE[wtIronOre] * 0.5; // Division into half because of iron weapon and armor
|
||||
for WT in IRON_WARFARE do
|
||||
fWareBalance[WT].FinalConsumption := maxIronWeapProd;
|
||||
|
||||
// Wooden weapons
|
||||
maxWoodWeapProd := maxWoodWeapProd * PRODUCTION_RATE[wtAxe]; // Production of weapons / armors is ~identical
|
||||
for WT in WOOD_WARFARE do
|
||||
fWareBalance[WT].FinalConsumption := maxWoodWeapProd;
|
||||
// Exceptions
|
||||
fWareBalance[wtLeatherArmor].FinalConsumption := maxWoodWeapProd;
|
||||
fWareBalance[wtWoodenShield].FinalConsumption := maxWoodWeapProd / 5; // This only affect wood requirements, shields will be ordered by count of axes
|
||||
|
||||
// Soldiers / min (only expected not final value)
|
||||
fMaxSoldiersInMin := maxWoodWeapProd + maxIronWeapProd;
|
||||
// Maybe there is no need to keep variable fMaxSoldiersInMin but I am afraid what scripters may do with fSetup
|
||||
if (fSetup.NewAI AND fSetup.UnlimitedEquip) then
|
||||
begin
|
||||
fSetup.EquipRateIron := Round(600 / Max(0.01, maxIronWeapProd));
|
||||
fSetup.EquipRateLeather := Round(600 / Max(0.01, maxWoodWeapProd));
|
||||
end;
|
||||
|
||||
// Predict final city stats (by potential size of city)
|
||||
fCityStats.CitizensCnt := Round( Max( 0, Min(fBuildCnt,4000)-1500 )*0.052+70 ); // Min cnt of citizens is 70 and max 200
|
||||
fCityStats.WarriorsCnt := Round( Max( 0, Min(fBuildCnt,4000)-1500 )*0.042+50 ); // Min cnt of soldiers is 50 and max 150
|
||||
UpdateWareBalance(True);
|
||||
|
||||
// Decide count of workers + build nodes
|
||||
freePlace := Max( 0, Min( 2000, Min(fFieldCnt,fBuildCnt) - 1000 ) ); // FreePlace in <0,2000>
|
||||
fWorkerCount := Round( Min( 50 - 35 * fUpdatedPeaceFactor * Byte(not gGame.IsPeaceTime), // Decrease count of required workers after peace
|
||||
15 + freePlace*AI_Par[PREDICTOR_WorkerCountCoef] + fPeaceFactor*8 )
|
||||
);
|
||||
// Try to build mines even when perf. optimalization prohibits it (once in ~8 min)
|
||||
if aIncrementMines then
|
||||
begin
|
||||
//Inc(fMaxGoldMineCnt);
|
||||
fDecCoalMineCnt := Max(0,fDecCoalMineCnt - 1);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
// City initialization, estimation of maximal possible production and restriction by peace time and loc properties
|
||||
procedure TKMCityPredictor.AfterMissionInit;
|
||||
const
|
||||
SCALE_MIN_PEACE_TIME = 50;
|
||||
SCALE_MAX_PEACE_TIME = 90;
|
||||
SCALE_PEACE_FACTOR = 1.0 / ((SCALE_MAX_PEACE_TIME - SCALE_MIN_PEACE_TIME)*1.0);
|
||||
begin
|
||||
// PeaceFactor: 0 = peace <= SCALE_MIN_PEACE_TIME; 1 = peace >= SCALE_MAX_PEACE_TIME
|
||||
//fPeaceFactor := Max(0,
|
||||
// (Min(SCALE_MAX_PEACE_TIME, gGame.Options.Peacetime) - SCALE_MIN_PEACE_TIME)
|
||||
// ) * SCALE_PEACE_FACTOR;
|
||||
fPeaceFactor := 0; // According to simulations the peace factor only harms
|
||||
|
||||
UpdateFinalProduction();
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCityPredictor.FilterRequiredHouses(aTick: Cardinal);
|
||||
|
||||
function UpdateFarmHistory(): Boolean;
|
||||
const
|
||||
CORN_DELAY = 10 * 60 * 6; // Delay 6 minutes or use array ProductionLag from KM_ResWares
|
||||
var
|
||||
I, K, cnt: Integer;
|
||||
begin
|
||||
with fFarmBuildHistory do
|
||||
begin
|
||||
// Remove old history
|
||||
if (Count > 1) then // Keep at least 1 element (the latest)
|
||||
begin
|
||||
I := 0;
|
||||
while (I < Count) do // Find the actual tick
|
||||
begin
|
||||
if (Tick[I] > aTick) then
|
||||
break;
|
||||
I := I + 1;
|
||||
end;
|
||||
if (I > 1) then // Keep the latest older element
|
||||
begin
|
||||
cnt := 0;
|
||||
for K := I - 1 to Count - 1 do // Remove old ticks
|
||||
begin
|
||||
Quantity[cnt] := Quantity[K];
|
||||
Tick[cnt] := Tick[K];
|
||||
cnt := cnt + 1;
|
||||
end;
|
||||
Count := cnt;
|
||||
end;
|
||||
end;
|
||||
cnt := gHands[fOwner].Stats.GetHouseQty(htFarm);
|
||||
if (Quantity[Count-1] <> cnt) then
|
||||
begin
|
||||
if (Length(Quantity) <= Count) then
|
||||
begin
|
||||
SetLength(Quantity, Length(Quantity) + 5);
|
||||
SetLength(Tick, Length(Tick) + 5);
|
||||
end;
|
||||
Quantity[Count] := cnt;
|
||||
Tick[Count] := aTick + CORN_DELAY;
|
||||
Count := Count + 1;
|
||||
end;
|
||||
end;
|
||||
Result := + fWareBalance[wtFlour].Production
|
||||
+ fWareBalance[wtPig].Production * 4
|
||||
+ fWareBalance[wtHorse].Production * 4
|
||||
>=
|
||||
+ fFarmBuildHistory.Quantity[0] * PRODUCTION_RATE[wtCorn]
|
||||
+ gHands[fOwner].Stats.GetWareBalance(wtCorn) * 0.25;
|
||||
end;
|
||||
{
|
||||
procedure CheckPeaceFactor();
|
||||
const
|
||||
IGNORE_HOUSES: set of TKMHouseType = [htCoalMine, htGoldMine, htIronMine, htQuary, htVineyard];
|
||||
var
|
||||
Cnt: Integer;
|
||||
HT: TKMHouseType;
|
||||
begin
|
||||
if (fUpdatedPeaceFactor < 1) then
|
||||
begin
|
||||
Cnt := 0;
|
||||
for HT := Low(RequiredHouses) to High(RequiredHouses) do
|
||||
if not (HT in IGNORE_HOUSES) AND gHands[fOwner].Locks.HouseCanBuild(HT) then
|
||||
Inc(Cnt, Max(0,RequiredHouses[HT]));
|
||||
if (Cnt >= 0) then
|
||||
UpdateFinalProduction(0.1);
|
||||
end;
|
||||
end;
|
||||
//}
|
||||
|
||||
const
|
||||
WEAP_WORKSHOP_DELAY = 35 * 60 * 10;
|
||||
WINEYARD_DELAY = 50 * 60 * 10;
|
||||
var
|
||||
stats: TKMHandStats;
|
||||
planner: TKMCityPlanner;
|
||||
begin
|
||||
planner := gHands[fOwner].AI.CityManagement.Builder.Planner;
|
||||
stats := gHands[fOwner].Stats;
|
||||
|
||||
// Dont build anything if there is not completed school
|
||||
if (fCityStats.Houses[htSchool] = 0)
|
||||
OR ( (fCityStats.Houses[htSchool] = 1)
|
||||
AND (not (planner.PlannedHouses[htSchool].Plans[0].Placed)
|
||||
OR not ( (planner.PlannedHouses[htSchool].Plans[0].House <> nil)
|
||||
AND planner.PlannedHouses[htSchool].Plans[0].House.IsComplete
|
||||
)
|
||||
)
|
||||
) then
|
||||
begin
|
||||
FillChar(RequiredHouses, SizeOf(RequiredHouses), #0);
|
||||
// Allow to reserve quarries
|
||||
UpdateWareProduction(wtStone);
|
||||
fWareBalance[wtStone].ActualConsumption := Min(fCityStats.Citizens[utBuilder]+8, fWorkerCount) * AI_Par[PREDICTOR_WareNeedPerAWorker_Stone];
|
||||
fWareBalance[wtStone].FinalConsumption := Max(fCityStats.Citizens[utBuilder], fWorkerCount) * AI_Par[PREDICTOR_WareNeedPerAWorker_Stone];
|
||||
UpdateWareDerivation(wtStone);
|
||||
RequiredHouses[htSchool] := Max(0, 1 - planner.PlannedHouses[htSchool].Count);
|
||||
Exit;
|
||||
end;
|
||||
|
||||
// Check requirements
|
||||
if not fCityUnderConstruction then
|
||||
UpdateFinalProduction(0.1);
|
||||
//CheckPeaceFactor();
|
||||
|
||||
// Remove unused houses (iron production)
|
||||
if (RequiredHouses[htIronSmithy] < 0) AND (stats.GetWareBalance(wtIronOre) < 20) then // Dont destroy iron production when there is still iron ore
|
||||
planner.RemoveHouseType(htIronSmithy);
|
||||
if (RequiredHouses[htArmorSmithy] < 0) AND (RequiredHouses[htIronSmithy] = 0) then // And dont destroy following production if you dont want to destroy IronSmithy
|
||||
planner.RemoveHouseType(htArmorSmithy);
|
||||
if (RequiredHouses[htWeaponSmithy] < 0) AND (RequiredHouses[htIronSmithy] = 0) then
|
||||
planner.RemoveHouseType(htWeaponSmithy);
|
||||
|
||||
|
||||
// Change house requirements due to nonlinear delay, toons of exceptions and unlock order
|
||||
// Dont build wineyard too early
|
||||
if (fUpdatedPeaceFactor < 1) then
|
||||
RequiredHouses[htVineyard] := 0;
|
||||
// Consideration of corn delay - only remove all required houses, builder will find the right one if they are not removed
|
||||
if UpdateFarmHistory() AND not gHands[fOwner].Locks.HouseBlocked[htFarm] then
|
||||
begin
|
||||
RequiredHouses[htMill] := Byte(fCityStats.Houses[htMill] = 0); // Allow 1 mill from the start
|
||||
RequiredHouses[htSwine] := 0;
|
||||
RequiredHouses[htStables] := 0;
|
||||
end;
|
||||
// Houses in dependence on corn delay
|
||||
RequiredHouses[htBakery] := Min(RequiredHouses[htBakery], stats.GetHouseQty(htMill) - fCityStats.Houses[htBakery]);
|
||||
RequiredHouses[htButchers] := Min(RequiredHouses[htButchers], Ceil(stats.GetHouseQty(htSwine)/3 - fCityStats.Houses[htButchers]));
|
||||
RequiredHouses[htTannery] := Min(RequiredHouses[htTannery], Ceil(stats.GetHouseQty(htSwine)/2 - fCityStats.Houses[htTannery]));
|
||||
RequiredHouses[htArmorWorkshop] := Min(RequiredHouses[htArmorWorkshop], stats.GetHouseTotal(htTannery)*2 - fCityStats.Houses[htArmorWorkshop]);
|
||||
// Consideration of wood production
|
||||
RequiredHouses[htWeaponWorkshop] := RequiredHouses[htWeaponWorkshop] * Byte( (RequiredHouses[htTannery] > 0) OR (WEAP_WORKSHOP_DELAY < aTick) OR (aTick > (gGame.Options.Peacetime-20) * 10 * 60) );
|
||||
|
||||
// Coal mines are used by top priority houses (Metallurgists) and low priority houses (smithy)
|
||||
// To get reasonable production there should use something like following logic, good luck with understanding ;)
|
||||
{
|
||||
RequiredHouses[htCoalMine] := Min( RequiredHouses[htCoalMine],
|
||||
Max( Planner.PlannedHouses[htMetallurgists].Count, // Gold production requirements
|
||||
RequiredHouses[htGoldMine]) // Build coal mine in parallel to gold mine
|
||||
+ Stats.GetHouseTotal(htIronSmithy) // Iron production requirements
|
||||
+ Stats.GetHouseTotal(htArmorSmithy)
|
||||
+ Stats.GetHouseTotal(htWeaponSmithy)
|
||||
- Planner.PlannedHouses[htCoalMine].Count
|
||||
); //}
|
||||
RequiredHouses[htCoalMine] := Max( planner.PlannedHouses[htMetallurgists].Count,RequiredHouses[htGoldMine]) // Gold production requirements
|
||||
- planner.PlannedHouses[htCoalMine].Count // Current production
|
||||
// Build coal mine in parallel to gold mine
|
||||
+ stats.GetHouseTotal(htIronSmithy) // Iron production requirements
|
||||
+ stats.GetHouseTotal(htArmorSmithy)
|
||||
+ stats.GetHouseTotal(htWeaponSmithy)
|
||||
+ 1; // +1 works better for some reason
|
||||
|
||||
// Consider exhausted city (save procesor time)
|
||||
RequiredHouses[htCoalMine] := RequiredHouses[htCoalMine] - fDecCoalMineCnt;
|
||||
RequiredHouses[htGoldMine] := Min(RequiredHouses[htGoldMine], fMaxGoldMineCnt);
|
||||
|
||||
// Logical house requirements (delay takes too long so it is not used)
|
||||
{
|
||||
RequiredHouses[htSwine] := RequiredHouses[htSwine] * Byte(Stats.GetWareBalance(wtCorn) > 0);
|
||||
RequiredHouses[htButchers] := RequiredHouses[htButchers] * Byte(Stats.GetWareBalance(wtPig) > 0);
|
||||
RequiredHouses[htTannery] := RequiredHouses[htTannery] * Byte(Stats.GetWareBalance(wtLeather) > 0);
|
||||
RequiredHouses[htArmorWorkshop] := RequiredHouses[htArmorWorkshop] * Byte(Stats.GetWareBalance(wtSkin) > 0);
|
||||
RequiredHouses[htMill] := RequiredHouses[htMill] * Byte(Stats.GetWareBalance(wtFlour) > 0);
|
||||
RequiredHouses[htBakery] := RequiredHouses[htBakery] * Byte(Stats.GetWareBalance(wtCorn) > 0);
|
||||
//}
|
||||
// Iron production (it will give time to build more mines)
|
||||
{
|
||||
RequiredHouses[htIronSmithy] := RequiredHouses[htIronSmithy] * Byte(Stats.GetWareBalance(wtIronOre) > 0);
|
||||
RequiredHouses[htWeaponSmithy] := RequiredHouses[htWeaponSmithy] * Byte(Stats.GetWareBalance(wtSteel) > 0);
|
||||
RequiredHouses[htArmorSmithy] := RequiredHouses[htArmorSmithy] * Byte(Stats.GetWareBalance(wtSteel) > 0);
|
||||
//}
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCityPredictor.UpdateState(aTick: Cardinal);
|
||||
const
|
||||
UPDATE_PRODUCTION = MAX_HANDS * 60 * 5;
|
||||
begin
|
||||
// Update final production (based on size of city, mines etc.)
|
||||
if (aTick mod UPDATE_PRODUCTION = fOwner) then
|
||||
UpdateFinalProduction(0, True);
|
||||
// Clear required houses
|
||||
FillChar(RequiredHouses, SizeOf(RequiredHouses), #0);
|
||||
// Update city stats
|
||||
UpdateCityStats();
|
||||
// Update prediction and other houses (production of ware)
|
||||
UpdateWareBalance();
|
||||
// Update required basic houses (main buildings)
|
||||
UpdateBasicHouses(aTick, False);
|
||||
|
||||
// Filter required houses
|
||||
FilterRequiredHouses(aTick);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCityPredictor.LogStatus(var aBalanceText: UnicodeString);
|
||||
const
|
||||
COLOR_WHITE = '[$FFFFFF]';
|
||||
COLOR_RED = '[$0000FF]';
|
||||
COLOR_YELLOW = '[$00FFFF]';
|
||||
COLOR_GREEN = '[$00FF00]';
|
||||
WARE_TO_STRING: array[WARE_MIN..WARE_MAX] of UnicodeString = (
|
||||
'Trunk'#9#9, 'Stone'#9#9, 'Wood'#9#9, 'Iron ore'#9, 'Gold ore'#9,
|
||||
'Coal'#9#9, 'Steel'#9#9, 'Gold'#9#9, 'Wine'#9#9, 'Corn'#9#9,
|
||||
'Bread'#9#9, 'Flour'#9#9, 'Leather'#9, 'Sausages'#9, 'Pig'#9#9,
|
||||
'Skin'#9#9, 'Shield'#9#9, 'MetalShield'#9#9, 'Armor'#9#9, 'MetalArmor'#9#9,
|
||||
'Axe'#9#9, 'Sword'#9#9, 'Pike'#9#9, 'Hallebard'#9#9, 'Bow'#9#9,
|
||||
'Arbalet'#9#9, 'Horse'#9#9, 'Fish'#9#9
|
||||
);
|
||||
|
||||
procedure AddWare(aWT: TKMWareType; const aSpecificText: String);
|
||||
var
|
||||
houseCntColor, productionColor, actualConsumptionColor, finalConsumptionColor, fractionColor, exhaustionColor: UnicodeString;
|
||||
cnt: Integer;
|
||||
begin
|
||||
cnt := RequiredHouses[ PRODUCTION_WARE2HOUSE[aWT] ];
|
||||
houseCntColor := COLOR_WHITE;
|
||||
if (cnt > 0) then
|
||||
houseCntColor := COLOR_RED;
|
||||
with fWareBalance[aWT] do
|
||||
begin
|
||||
productionColor := COLOR_YELLOW;
|
||||
actualConsumptionColor := COLOR_YELLOW;
|
||||
finalConsumptionColor := COLOR_YELLOW;
|
||||
fractionColor := COLOR_YELLOW;
|
||||
exhaustionColor := COLOR_RED;
|
||||
|
||||
if (Production > 0) then productionColor := COLOR_GREEN;
|
||||
if (ActualConsumption > 0) then actualConsumptionColor := COLOR_RED;
|
||||
if (FinalConsumption > 0) then finalConsumptionColor := COLOR_RED;
|
||||
if (Fraction <= 0.1) then fractionColor := COLOR_GREEN
|
||||
else fractionColor := COLOR_RED;
|
||||
if (Exhaustion > 10) then exhaustionColor := COLOR_GREEN
|
||||
else if (Exhaustion > 1) then exhaustionColor := COLOR_YELLOW;
|
||||
|
||||
aBalanceText := Format('%s'#9 +
|
||||
'%s%dx %s' +
|
||||
'%s'#9 +
|
||||
'%s%5.2f%s'#9#9#9 +
|
||||
'%s%5.2f%s'#9#9#9#9 +
|
||||
'%s%5.2f%s'#9#9#9 +
|
||||
'%s%5.2f%s'#9#9 +
|
||||
'%s%5.2f%s|',
|
||||
[ aBalanceText,
|
||||
houseCntColor, cnt, COLOR_WHITE,
|
||||
aSpecificText,
|
||||
productionColor, Production, COLOR_WHITE,
|
||||
actualConsumptionColor, ActualConsumption, COLOR_WHITE,
|
||||
finalConsumptionColor, FinalConsumption, COLOR_WHITE,
|
||||
fractionColor, Fraction, COLOR_WHITE,
|
||||
exhaustionColor, Exhaustion, COLOR_WHITE
|
||||
]
|
||||
);
|
||||
end;
|
||||
end;
|
||||
var
|
||||
K: Integer;
|
||||
begin
|
||||
aBalanceText := Format('%sWare balance|Required houses'#9'Production'#9#9'Actual consumption'#9#9'Final consumption'#9#9'Fraction'#9'Exhaustion|',[aBalanceText]);
|
||||
for K := CO_WARE_MIN to CO_WARE_MAX do
|
||||
AddWare(CONSUMPTION_ORDER[K], WARE_TO_STRING[ CONSUMPTION_ORDER[K] ]);
|
||||
AddWare(wtLeatherArmor, 'Armor'#9#9);
|
||||
AddWare(wtAxe, 'Weapon'#9#9);
|
||||
AddWare(wtIronArmor, 'Iron Armor'#9);
|
||||
AddWare(wtSword, 'Iron Weapon'#9);
|
||||
aBalanceText := Format('%sPeace factor = %1.2f (update = %1.2f); Max workers: %d; Max gold = %d; Dec coal = %d; Iron = %d; Field coef = %d; Build coef = %d; |', [aBalanceText, fPeaceFactor, fUpdatedPeaceFactor, fWorkerCount, fMaxGoldMineCnt, fDecCoalMineCnt, fIronMineCnt, fFieldCnt, fBuildCnt]);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
+1977
File diff suppressed because it is too large.
Load diff
+1518
File diff suppressed because it is too large.
Load diff
+1894
File diff suppressed because it is too large.
Load diff
@@ -0,0 +1,443 @@
|
||||
unit KM_CommonClassesExt;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
SysUtils, TypInfo, Generics.Collections,
|
||||
KM_CommonClasses, KM_CommonTypes;
|
||||
|
||||
type
|
||||
ERuntimeTypeError = class(Exception);
|
||||
|
||||
TSet<T> = class
|
||||
const
|
||||
BIT_MASKS: array [0..7] of Byte = (1, 2, 4, 8, 16, 32, 64, 128);
|
||||
strict private
|
||||
class function TypeInfo: PTypeInfo; inline; static;
|
||||
class function GetCardinality(const PSet: PByteArray; const SizeOfSet(*in bytes*): Integer): Integer; inline; static;
|
||||
class function GetSetToString(const PSet: PByteArray; const SizeOfSet(*in bytes*): Integer): String; static;
|
||||
public
|
||||
class function IsSet: Boolean; static;
|
||||
class function Cardinality(const Value: T): Integer; static;
|
||||
class function SetToString(const Value: T): String; static;
|
||||
end;
|
||||
|
||||
// List with unique elements
|
||||
// Potentially very slow implementation because of 'Contains'
|
||||
// (which loops through whole list when adding 1 element)
|
||||
// However, we use it for Grou.UnitTypes which is at most like 4 values xD
|
||||
TKMListUnique<T> = class(TList<T>)
|
||||
public
|
||||
function Add(const Value: T): Integer; reintroduce;
|
||||
end;
|
||||
|
||||
|
||||
TKMWeightedList<T> = class(TList<T>)
|
||||
fWeight: array of Single;
|
||||
public
|
||||
procedure Add(const aValue: T; aWeight: Single); reintroduce;
|
||||
function GetWeightedRandom(out aValue: T): Boolean;
|
||||
end;
|
||||
|
||||
TKMLimitedList<T> = class(TList<T>)
|
||||
private
|
||||
fMaxLength: Integer;
|
||||
public
|
||||
constructor Create(aMaxLength: Integer);
|
||||
function Add(const Value: T): Integer; reintroduce;
|
||||
end;
|
||||
|
||||
TKMLimitedUniqueList<T> = class(TKMLimitedList<T>)
|
||||
public
|
||||
constructor Create(aMaxLength: Integer);
|
||||
|
||||
function Add(const Value: T): Integer; reintroduce;
|
||||
end;
|
||||
|
||||
TKMEnumUtils = class
|
||||
class function TryGetAs<T>(aEnumStr: String; out aEnumValue: T): Boolean;
|
||||
end;
|
||||
|
||||
TKMVarValue = class
|
||||
private
|
||||
type
|
||||
TKMVarValueType = (rcNone, rcAnsiString, rcUnicodeString, rcInteger, rcExtended, rcBoolean);
|
||||
var
|
||||
fType: TKMVarValueType;
|
||||
fStrA: AnsiString;
|
||||
fStrW: UnicodeString;
|
||||
fInt: Int64;
|
||||
fExtn: Extended;
|
||||
fBool: Boolean;
|
||||
public
|
||||
constructor Create(aVarRec: TVarRec); overload;
|
||||
|
||||
procedure SetByVarRec(aValue: TVarRec);
|
||||
function ToVarRec: TVarRec;
|
||||
|
||||
procedure Save(aStream: TKMemoryStream);
|
||||
procedure Load(aStream: TKMemoryStream);
|
||||
end;
|
||||
|
||||
TKMVarValueList = class(TObjectList<TKMVarValue>)
|
||||
public
|
||||
function ToVarRecArray: TKMVarRecArray;
|
||||
procedure AddVarRecs(aParams: array of const);
|
||||
|
||||
procedure Save(aSaveStream: TKMemoryStream);
|
||||
procedure Load(aLoadStream: TKMemoryStream);
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
KM_CommonUtils;
|
||||
|
||||
|
||||
{ TSet<T>
|
||||
|
||||
Usage: Writeln(TSet<SomeSet>.Cardinality(Value));
|
||||
|
||||
taken from:
|
||||
https://stackoverflow.com/questions/34442102/how-can-i-get-the-number-of-elements-of-any-variable-of-type-set }
|
||||
class function TSet<T>.TypeInfo: PTypeInfo;
|
||||
begin
|
||||
Result := System.TypeInfo(T);
|
||||
end;
|
||||
|
||||
|
||||
class function TSet<T>.IsSet: Boolean;
|
||||
begin
|
||||
Result := TypeInfo.Kind = tkSet;
|
||||
end;
|
||||
|
||||
|
||||
class function TSet<T>.GetCardinality(const PSet: PByteArray; const SizeOfSet(*in bytes*): Integer): Integer;
|
||||
var
|
||||
I, J: Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
for I := 0 to SizeOfSet - 1 do
|
||||
for J := 0 to 7 do
|
||||
if (PSet^[I] and BIT_MASKS[J]) > 0 then
|
||||
Inc(Result);
|
||||
end;
|
||||
|
||||
|
||||
class function TSet<T>.GetSetToString(const PSet: PByteArray; const SizeOfSet(*in bytes*): Integer): String;
|
||||
var
|
||||
I, J: Integer;
|
||||
BaseType: PTypeInfo;
|
||||
begin
|
||||
Result := '';
|
||||
|
||||
BaseType := GetTypeData(TypeInfo).CompType{$IFDEF WDC}^{$ENDIF}; //FPC has PTypeInfo here, while WDC has PPTypeInfo
|
||||
|
||||
for I := 0 to SizeOfSet - 1 do
|
||||
for J := 0 to 7 do
|
||||
if (PSet^[I] and BIT_MASKS[J]) > 0 then
|
||||
begin
|
||||
if Result <> '' then
|
||||
Result := Result + ', ';
|
||||
{$IFDEF WDC}
|
||||
Result := Result + GetEnumName(BaseType, J + I*8);
|
||||
{$ENDIF}
|
||||
{$IFDEF FPC}
|
||||
if BaseType^.Kind = tkInteger then //For some reason FPC can't return EnumName, at least for tkInteger values
|
||||
Result := Result + IntToStr(J + I*8)
|
||||
else
|
||||
Result := Result + GetEnumName(BaseType, J + I*8);
|
||||
{$ENDIF}
|
||||
end;
|
||||
Result := '[' + Result + ']';
|
||||
end;
|
||||
|
||||
|
||||
class function TSet<T>.Cardinality(const Value: T): Integer;
|
||||
begin
|
||||
if not IsSet then
|
||||
raise ERuntimeTypeError.Create('Invalid type in TSet<T>, T must be a set');
|
||||
Result := GetCardinality(PByteArray(@Value), SizeOf(Value));
|
||||
end;
|
||||
|
||||
|
||||
class function TSet<T>.SetToString(const Value: T): String;
|
||||
begin
|
||||
if not IsSet then
|
||||
raise ERuntimeTypeError.Create('Invalid type in TSet<T>, T must be a set');
|
||||
|
||||
Result := GetSetToString(PByteArray(@Value), SizeOf(Value));
|
||||
end;
|
||||
|
||||
|
||||
{ TKMEnumUtils }
|
||||
// example from https://stackoverflow.com/questions/2472487/converting-an-string-to-a-enum-type-using-tvalue
|
||||
// Get enum value from enum string
|
||||
class function TKMEnumUtils.TryGetAs<T>(aEnumStr: String; out aEnumValue: T): Boolean;
|
||||
var
|
||||
tipInfo: PTypeInfo;
|
||||
enumIntVal: Integer;
|
||||
PEnumVal: Pointer;
|
||||
begin
|
||||
tipInfo := TypeInfo(T);
|
||||
enumIntVal := GetEnumValue(tipInfo, aEnumStr);
|
||||
|
||||
if enumIntVal = -1 then
|
||||
Exit(False);
|
||||
|
||||
PEnumVal := @enumIntVal;
|
||||
aEnumValue := T(PEnumVal^);
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
|
||||
{ TKMListUnique<T> }
|
||||
function TKMListUnique<T>.Add(const Value: T): Integer;
|
||||
begin
|
||||
if Contains(Value) then Exit(0);
|
||||
|
||||
Result := inherited Add(Value);
|
||||
end;
|
||||
|
||||
|
||||
{ TKMWeightedList }
|
||||
procedure TKMWeightedList<T>.Add(const aValue: T; aWeight: Single);
|
||||
begin
|
||||
inherited Add(aValue);
|
||||
|
||||
if Count >= Length(fWeight) then
|
||||
SetLength(fWeight, Count + 32);
|
||||
|
||||
fWeight[Count - 1] := aWeight;
|
||||
end;
|
||||
|
||||
|
||||
function TKMWeightedList<T>.GetWeightedRandom(out aValue: T): Boolean;
|
||||
var
|
||||
I: Integer;
|
||||
WeightsSum, Rnd: Extended;
|
||||
begin
|
||||
Result := False;
|
||||
|
||||
if Count = 0 then
|
||||
Exit;
|
||||
|
||||
WeightsSum := 0;
|
||||
for I := 0 to Count - 1 do
|
||||
WeightsSum := WeightsSum + fWeight[I];
|
||||
|
||||
Rnd := KaMRandomS1(WeightsSum{$IFDEF DBG_RNG_SPY}, 'TKMWeightedList.GetWeightedRandom'{$ENDIF});
|
||||
|
||||
for I := 0 to Count - 1 do
|
||||
begin
|
||||
if Rnd < fWeight[I] then
|
||||
begin
|
||||
aValue := Items[I];
|
||||
Exit(True);
|
||||
end;
|
||||
Rnd := Rnd - fWeight[I];
|
||||
end;
|
||||
Assert(False, 'Error getting weighted random');
|
||||
end;
|
||||
|
||||
|
||||
{ TKMLimitedList<T> }
|
||||
constructor TKMLimitedList<T>.Create(aMaxLength: Integer);
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
fMaxLength := aMaxLength;
|
||||
end;
|
||||
|
||||
|
||||
function TKMLimitedList<T>.Add(const Value: T): Integer;
|
||||
begin
|
||||
Result := inherited Add(Value);
|
||||
|
||||
if Count > fMaxLength then
|
||||
Delete(0); // Delete the oldest item
|
||||
end;
|
||||
|
||||
|
||||
{ TKMLimitedUniqueList }
|
||||
constructor TKMLimitedUniqueList<T>.Create(aMaxLength: Integer);
|
||||
begin
|
||||
inherited Create(aMaxLength);
|
||||
end;
|
||||
|
||||
|
||||
function TKMLimitedUniqueList<T>.Add(const Value: T): Integer;
|
||||
begin
|
||||
if Contains(Value) then Exit(0);
|
||||
|
||||
Result := inherited Add(Value);
|
||||
|
||||
if Count > fMaxLength then
|
||||
begin
|
||||
Delete(0); // Delete the oldest item
|
||||
Result := Result - 1;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{ TKMVarValue }
|
||||
constructor TKMVarValue.Create(aVarRec: TVarRec);
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
SetByVarRec(aVarRec);
|
||||
end;
|
||||
|
||||
|
||||
function TKMVarValue.ToVarRec: TVarRec;
|
||||
begin
|
||||
case fType of
|
||||
rcAnsiString: begin
|
||||
Result.VType := vtAnsiString;
|
||||
Result.VAnsiString := Pointer(fStrA);
|
||||
end;
|
||||
rcUnicodeString:begin
|
||||
Result.VType := vtUnicodeString;
|
||||
Result.VUnicodeString := Pointer(fStrW);
|
||||
end;
|
||||
rcInteger: begin
|
||||
Result.VType := vtInt64;
|
||||
Result.VInt64 := @fInt;
|
||||
end;
|
||||
rcExtended: begin
|
||||
Result.VType := vtExtended;
|
||||
Result.VExtended := @fExtn;
|
||||
end;
|
||||
rcBoolean: begin
|
||||
Result.VType := vtBoolean;
|
||||
Result.VBoolean := fBool;
|
||||
end;
|
||||
else
|
||||
raise Exception.Create('Unexpected type');
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMVarValue.SetByVarRec(aValue: TVarRec);
|
||||
begin
|
||||
with aValue do
|
||||
begin
|
||||
case VType of
|
||||
vtInteger: fInt := VInteger;
|
||||
vtBoolean: fBool := VBoolean;
|
||||
vtChar: fStrA := VChar;
|
||||
vtExtended: fExtn := VExtended^;
|
||||
vtInt64: fInt := VInt64^;
|
||||
vtPChar: fStrA := VPChar^;
|
||||
vtPWideChar: fStrW := string(VPWideChar^);
|
||||
vtString: fStrA := VString^;
|
||||
vtAnsiString: fStrA := AnsiString(VAnsiString);
|
||||
vtUnicodeString: fStrW := string(VUnicodeString);
|
||||
else
|
||||
raise Exception.Create('Unexpected type');
|
||||
end;
|
||||
|
||||
fType := rcNone;
|
||||
case VType of
|
||||
vtInteger,
|
||||
vtInt64: fType := rcInteger;
|
||||
vtBoolean: fType := rcBoolean;
|
||||
vtExtended: fType := rcExtended;
|
||||
vtChar,
|
||||
vtPChar,
|
||||
vtString,
|
||||
vtAnsiString: fType := rcAnsiString;
|
||||
vtPWideChar,
|
||||
vtUnicodeString: fType := rcUnicodeString;
|
||||
else
|
||||
raise Exception.Create('Unexpected type');
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMVarValue.Load(aStream: TKMemoryStream);
|
||||
begin
|
||||
aStream.Read(fType, SizeOf(fType));
|
||||
|
||||
case fType of
|
||||
rcAnsiString: aStream.ReadA(fStrA);
|
||||
rcUnicodeString: aStream.ReadW(fStrW);
|
||||
rcInteger: aStream.Read(fInt);
|
||||
rcExtended: aStream.Read(fExtn);
|
||||
rcBoolean: aStream.Read(fBool);
|
||||
else
|
||||
raise Exception.Create('Unexpected type');
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMVarValue.Save(aStream: TKMemoryStream);
|
||||
begin
|
||||
aStream.Write(fType, SizeOf(fType));
|
||||
|
||||
case fType of
|
||||
rcAnsiString: aStream.WriteA(fStrA);
|
||||
rcUnicodeString: aStream.WriteW(fStrW);
|
||||
rcInteger: aStream.Write(fInt);
|
||||
rcExtended: aStream.Write(fExtn);
|
||||
rcBoolean: aStream.Write(fBool);
|
||||
else
|
||||
raise Exception.Create('Unexpected type');
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{ TKMVarValueList }
|
||||
procedure TKMVarValueList.AddVarRecs(aParams: array of const);
|
||||
var
|
||||
I: Integer;
|
||||
varValue: TKMVarValue;
|
||||
begin
|
||||
for I := 0 to High(aParams) do
|
||||
begin
|
||||
varValue := TKMVarValue.Create(aParams[I]);
|
||||
Add(varValue);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMVarValueList.ToVarRecArray: TKMVarRecArray;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
SetLength(Result, Count);
|
||||
|
||||
for I := 0 to Count - 1 do
|
||||
Result[I] := Items[I].ToVarRec;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMVarValueList.Load(aLoadStream: TKMemoryStream);
|
||||
var
|
||||
I, cnt: Integer;
|
||||
varRec: TKMVarValue;
|
||||
begin
|
||||
aLoadStream.CheckMarker('VarValueList');
|
||||
aLoadStream.Read(cnt);
|
||||
for I := 0 to cnt - 1 do
|
||||
begin
|
||||
varRec := TKMVarValue.Create;
|
||||
varRec.Load(aLoadStream);
|
||||
Add(varRec);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMVarValueList.Save(aSaveStream: TKMemoryStream);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
aSaveStream.PlaceMarker('VarValueList');
|
||||
aSaveStream.Write(Count);
|
||||
for I := 0 to Count - 1 do
|
||||
Items[I].Save(aSaveStream);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
@@ -0,0 +1,29 @@
|
||||
unit KM_CommonExceptions;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
SysUtils, KM_Points;
|
||||
|
||||
type
|
||||
//Custom Exception that includes a TKMPoint
|
||||
ELocError = class(Exception)
|
||||
Loc: TKMPoint;
|
||||
constructor Create(const aMsg: UnicodeString; const aLoc: TKMPoint);
|
||||
end;
|
||||
|
||||
// Error while game initialization
|
||||
// madExcept ignores it, since we just want to show simple message instead
|
||||
EGameInitError = class(Exception);
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
{ ELocError }
|
||||
constructor ELocError.Create(const aMsg: UnicodeString; const aLoc: TKMPoint);
|
||||
begin
|
||||
inherited Create(aMsg);
|
||||
Loc := aLoc;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,10 @@
|
||||
unit KM_CommonGameTypes;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
|
||||
type
|
||||
TKMProjectileType = (ptArrow, ptBolt, ptSlingRock, ptTowerRock); {ptBallistaRock, }
|
||||
|
||||
implementation
|
||||
|
||||
end.
|
||||
+337
@@ -0,0 +1,337 @@
|
||||
unit KM_CommonTypes;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
KM_Points;
|
||||
|
||||
type
|
||||
TKMByteSet = set of Byte;
|
||||
//* Array of bytes
|
||||
//Legacy support for old scripts
|
||||
TByteSet = set of Byte;
|
||||
|
||||
TBooleanArray = array of Boolean;
|
||||
TBoolean2Array = array of array of Boolean;
|
||||
TKMByteArray = array of Byte;
|
||||
TKMByte2Array = array of TKMByteArray;
|
||||
TKMByteSetArray = array of TKMByteSet;
|
||||
PKMByte2Array = ^TKMByte2Array;
|
||||
TKMWordArray = array of Word;
|
||||
TKMWord2Array = array of array of Word;
|
||||
PKMWordArray = ^TKMWordArray;
|
||||
TKMCardinalArray = array of Cardinal;
|
||||
PKMCardinalArray = ^TKMCardinalArray;
|
||||
TSmallIntArray = array of SmallInt;
|
||||
//* array of integer values
|
||||
TIntegerArray = array of Integer;
|
||||
TInteger2Array = array of array of Integer;
|
||||
//* array of string values
|
||||
TAnsiStringArray = array of AnsiString;
|
||||
TSingleArray = array of Single;
|
||||
TSingle2Array = array of array of Single;
|
||||
TKMStringArray = array of string;
|
||||
TKMCharArray = array of Char;
|
||||
TRGB = record R,G,B: Byte end;
|
||||
TRGBArray = array of TRGB;
|
||||
TKMStaticByteArray = array [0..MaxInt - 1] of Byte;
|
||||
PKMStaticByteArray = ^TKMStaticByteArray;
|
||||
TKMVarRecArray = array of TVarRec;
|
||||
|
||||
TKMEvent = procedure of object;
|
||||
TPointEventSimple = procedure (const X,Y: Integer) of object;
|
||||
TPointFEvent = procedure (const aPoint: TKMPointF) of object;
|
||||
TBooleanEvent = procedure (aValue: Boolean) of object;
|
||||
TIntegerEvent = procedure (aValue: Integer) of object;
|
||||
TIntBoolEvent = procedure (aIntValue: Integer; aBoolValue: Boolean) of object;
|
||||
TObjectIntegerEvent = procedure (Sender: TObject; X: Integer) of object;
|
||||
TSingleEvent = procedure (aValue: Single) of object;
|
||||
TAnsiStringEvent = procedure (const aData: AnsiString) of object;
|
||||
TUnicodeStringEvent = procedure (const aData: UnicodeString) of object;
|
||||
TUnicodeStringWDefEvent = procedure (const aData: UnicodeString = '') of object;
|
||||
TUnicodeStringEventProc = procedure (const aData: UnicodeString);
|
||||
TUnicode2StringEventProc = procedure (const aData1, aData2: UnicodeString);
|
||||
TUnicodeStringObjEvent = procedure (Obj: TObject; const aData: UnicodeString) of object;
|
||||
TUnicodeStringObjEventProc = procedure (Sender: TObject; const aData: UnicodeString);
|
||||
TUnicodeStringBoolEvent = procedure (const aData: UnicodeString; aBool: Boolean) of object;
|
||||
TGameStartEvent = procedure (const aData: UnicodeString; Spectating: Boolean) of object;
|
||||
TResyncEvent = procedure (aSender: ShortInt; aTick: cardinal) of object;
|
||||
TIntegerStringEvent = procedure (aValue: Integer; const aText: UnicodeString) of object;
|
||||
TBooleanFunc = function(Obj: TObject): Boolean of object;
|
||||
TBooleanWordFunc = function (aValue: Word): Boolean of object;
|
||||
TBooleanStringFunc = function (const aValue: String): Boolean of object;
|
||||
TBooleanFuncSimple = function: Boolean of object;
|
||||
TBoolIntFuncSimple = function (aValue: Integer): Boolean of object;
|
||||
TBoolCardFuncSimple = function (aValue: Cardinal): Boolean of object;
|
||||
TCardinalEvent = procedure (aValue: Cardinal) of object;
|
||||
TCoordDistanceFn = function (X, Y: Integer): Single;
|
||||
|
||||
{$IFDEF FPC}
|
||||
TProc = procedure;
|
||||
{$ENDIF}
|
||||
|
||||
TKMAnimLoop = packed record
|
||||
Step: array [1 .. 30] of SmallInt;
|
||||
Count: SmallInt;
|
||||
MoveX, MoveY: Integer;
|
||||
end;
|
||||
PKMAnimLoop = ^TKMAnimLoop;
|
||||
|
||||
TKMCursorDir = (cdNone = 0, cdForward = 1, cdBack = -1);
|
||||
|
||||
TWonOrLost = (wolNone, wolWon, wolLost);
|
||||
|
||||
//Menu load type - load / no load / load unsupported version
|
||||
TKMGameStartMode = (gsmNoStart, gsmStart, gsmStartWithWarn, gsmNoStartWithWarn);
|
||||
|
||||
TKMCustomScriptParam = (cspTHTroopCosts, cspMarketGoldPrice);
|
||||
|
||||
TKMCustomScriptParamData = record
|
||||
Added: Boolean;
|
||||
Data: UnicodeString;
|
||||
end;
|
||||
|
||||
TKMImageType = (itJpeg, itPng, itBmp);
|
||||
|
||||
TKMUserActionType = (uatNone, uatKeyDown, uatKeyUp, uatKeyPress, uatMouseDown, uatMouseUp, uatMouseMove, uatMouseWheel);
|
||||
TKMUserActionEvent = procedure (aActionType: TKMUserActionType) of object;
|
||||
|
||||
|
||||
TKMCustomScriptParamDataArray = array [TKMCustomScriptParam] of TKMCustomScriptParamData;
|
||||
|
||||
TKMPlayerColorMode = (pcmNone, pcmDefault, pcmAllyEnemy, pcmTeams);
|
||||
|
||||
TKMGameRevision = Word; // Word looks enough for now...
|
||||
|
||||
TKMColor3f = record
|
||||
R,G,B: Single;
|
||||
function ToCardinal: Cardinal;
|
||||
class function Generic(aIndex: Integer): TKMColor3f; static;
|
||||
class function RandomWSeed(aSeed: Integer): TKMColor3f; static;
|
||||
class function New(aR,aG,aB: Single): TKMColor3f; static;
|
||||
class function NewB(aR,aG,aB: Byte): TKMColor3f; static;
|
||||
class function NewC(aRGB: Cardinal): TKMColor3f; static;
|
||||
function ToString: string;
|
||||
end;
|
||||
|
||||
TKMColor3b = record
|
||||
R,G,B: Byte;
|
||||
function ToCardinal: Cardinal;
|
||||
class function New(aR,aG,aB: Byte): TKMColor3b; static;
|
||||
end;
|
||||
|
||||
TKMColor4f = record
|
||||
R,G,B,A: Single;
|
||||
class function New(aR,aG,aB,aA: Single): TKMColor4f; overload; static;
|
||||
class function New(aR,aG,aB: Byte): TKMColor4f; overload; static;
|
||||
class function NewB(aR,aG,aB,aA: Byte): TKMColor4f; overload; static;
|
||||
class function New(aCol: Cardinal): TKMColor4f; overload; static;
|
||||
class function New(aCol: TKMColor3f): TKMColor4f; overload; static;
|
||||
class function New(const aCol: TKMColor3f; aAlpha: Single): TKMColor4f; overload; static;
|
||||
class function White: TKMColor4f; static;
|
||||
class function Black: TKMColor4f; static;
|
||||
function Alpha50: TKMColor4f;
|
||||
function Alpha(aAlpha: Single): TKMColor4f;
|
||||
function ToColor3f: TKMColor3f;
|
||||
function ToCardinal: Cardinal;
|
||||
end;
|
||||
|
||||
TKMColor3bArray = array of TKMColor3b;
|
||||
|
||||
const
|
||||
COLOR3F_WHITE: TKMColor3f = (R: 1; G: 1; B: 1);
|
||||
COLOR3F_BLACK: TKMColor3f = (R: 0; G: 0; B: 0);
|
||||
|
||||
COLOR4F_WHITE: TKMColor4f = (R: 1; G: 1; B: 1; A: 1);
|
||||
COLOR4F_BLACK: TKMColor4f = (R: 0; G: 0; B: 0; A: 1);
|
||||
|
||||
const
|
||||
IMAGE_TYPE_EXT: array[TKMImageType] of string = ('.jpeg', '.png', '.bmp');
|
||||
|
||||
const
|
||||
WonOrLostText: array [TWonOrLost] of UnicodeString = ('None', 'Won', 'Lost');
|
||||
|
||||
NO_SUCCESS_INT: Integer = -1;
|
||||
|
||||
implementation
|
||||
uses
|
||||
Math, SysUtils, KM_CommonUtils;
|
||||
|
||||
|
||||
{ TKMColor3f }
|
||||
class function TKMColor3f.New(aR, aG, aB: Single): TKMColor3f;
|
||||
begin
|
||||
Result.R := aR;
|
||||
Result.G := aG;
|
||||
Result.B := aB;
|
||||
end;
|
||||
|
||||
|
||||
class function TKMColor3f.NewB(aR, aG, aB: Byte): TKMColor3f;
|
||||
begin
|
||||
Result.R := aR / 255;
|
||||
Result.G := aG / 255;
|
||||
Result.B := aB / 255;
|
||||
end;
|
||||
|
||||
|
||||
class function TKMColor3f.NewC(aRGB: Cardinal): TKMColor3f;
|
||||
begin
|
||||
Result.B := (aRGB and $FF) / 255;
|
||||
Result.G := (aRGB shr 8 and $FF) / 255;
|
||||
Result.R := (aRGB shr 16 and $FF) / 255;
|
||||
end;
|
||||
|
||||
|
||||
function TKMColor3f.ToCardinal: Cardinal;
|
||||
begin
|
||||
Result := (Round(R * 255) + (Round(G * 255) shl 8) + (Round(B * 255) shl 16)) {or $FF000000};
|
||||
end;
|
||||
|
||||
|
||||
class function TKMColor3f.Generic(aIndex: Integer): TKMColor3f;
|
||||
const
|
||||
MAX_GENERIC_COLORS = 6;
|
||||
GENERIC_COLORS: array [0..MAX_GENERIC_COLORS-1] of TKMColor3f = (
|
||||
(R:1.0; G:0.2; B:0.2),
|
||||
(R:1.0; G:1.0; B:0.2),
|
||||
(R:0.2; G:1.0; B:0.2),
|
||||
(R:0.2; G:1.0; B:1.0),
|
||||
(R:0.2; G:0.2; B:1.0),
|
||||
(R:1.0; G:0.2; B:1.0)
|
||||
);
|
||||
begin
|
||||
Result := GENERIC_COLORS[aIndex mod MAX_GENERIC_COLORS];
|
||||
end;
|
||||
|
||||
|
||||
class function TKMColor3f.RandomWSeed(aSeed: Integer): TKMColor3f;
|
||||
begin
|
||||
Result.R := KaMRandomWSeedS1(aSeed, 1);
|
||||
Result.G := KaMRandomWSeedS1(aSeed, 1);
|
||||
Result.B := KaMRandomWSeedS1(aSeed, 1);
|
||||
end;
|
||||
|
||||
|
||||
function TKMColor3f.ToString: string;
|
||||
begin
|
||||
Result := Format('[%d:%d:%d]', [Round(255*R), Round(255*G), Round(255*B)]);
|
||||
end;
|
||||
|
||||
|
||||
{ TKMColor3b }
|
||||
class function TKMColor3b.New(aR, aG, aB: Byte): TKMColor3b;
|
||||
begin
|
||||
Result.R := aR;
|
||||
Result.G := aG;
|
||||
Result.B := aB;
|
||||
end;
|
||||
|
||||
|
||||
function TKMColor3b.ToCardinal: Cardinal;
|
||||
begin
|
||||
Result := (R + (G shl 8) + (B shl 16)); {or $FF000000};
|
||||
end;
|
||||
|
||||
|
||||
{ TKMColor4f }
|
||||
class function TKMColor4f.New(aR,aG,aB,aA: Single): TKMColor4f;
|
||||
begin
|
||||
Result.R := aR;
|
||||
Result.G := aG;
|
||||
Result.B := aB;
|
||||
Result.A := aA;
|
||||
end;
|
||||
|
||||
|
||||
class function TKMColor4f.New(aR,aG,aB: Byte): TKMColor4f;
|
||||
begin
|
||||
Result.R := aR / 255;
|
||||
Result.G := aG / 255;
|
||||
Result.B := aB / 255;
|
||||
Result.A := 1;
|
||||
end;
|
||||
|
||||
|
||||
class function TKMColor4f.NewB(aR,aG,aB,aA: Byte): TKMColor4f;
|
||||
begin
|
||||
Result.R := aR / 255;
|
||||
Result.G := aG / 255;
|
||||
Result.B := aB / 255;
|
||||
Result.A := aA / 255;
|
||||
end;
|
||||
|
||||
|
||||
class function TKMColor4f.New(aCol: Cardinal): TKMColor4f;
|
||||
begin
|
||||
Result.R := (aCol and $FF) / 255;
|
||||
Result.G := ((aCol shr 8) and $FF) / 255;
|
||||
Result.B := ((aCol shr 16) and $FF) / 255;
|
||||
Result.A := ((aCol shr 24) and $FF) / 255;
|
||||
end;
|
||||
|
||||
|
||||
class function TKMColor4f.New(aCol: TKMColor3f): TKMColor4f;
|
||||
begin
|
||||
Result.R := aCol.R;
|
||||
Result.G := aCol.G;
|
||||
Result.B := aCol.B;
|
||||
Result.A := 1;
|
||||
end;
|
||||
|
||||
|
||||
class function TKMColor4f.New(const aCol: TKMColor3f; aAlpha: Single): TKMColor4f;
|
||||
begin
|
||||
Result.R := aCol.R;
|
||||
Result.G := aCol.G;
|
||||
Result.B := aCol.B;
|
||||
Result.A := aAlpha;
|
||||
end;
|
||||
|
||||
|
||||
class function TKMColor4f.White: TKMColor4f;
|
||||
begin
|
||||
Result.R := 1;
|
||||
Result.G := 1;
|
||||
Result.B := 1;
|
||||
Result.A := 1;
|
||||
end;
|
||||
|
||||
|
||||
class function TKMColor4f.Black: TKMColor4f;
|
||||
begin
|
||||
Result.R := 0;
|
||||
Result.G := 0;
|
||||
Result.B := 0;
|
||||
Result.A := 1;
|
||||
end;
|
||||
|
||||
|
||||
function TKMColor4f.Alpha50: TKMColor4f;
|
||||
begin
|
||||
Result := Self;
|
||||
Result.A := 0.5;
|
||||
end;
|
||||
|
||||
|
||||
function TKMColor4f.Alpha(aAlpha: Single): TKMColor4f;
|
||||
begin
|
||||
Result := Self;
|
||||
Result.A := aAlpha;
|
||||
end;
|
||||
|
||||
|
||||
function TKMColor4f.ToColor3f: TKMColor3f;
|
||||
begin
|
||||
Result.R := R;
|
||||
Result.G := G;
|
||||
Result.B := B;
|
||||
end;
|
||||
|
||||
|
||||
function TKMColor4f.ToCardinal: Cardinal;
|
||||
begin
|
||||
Result := Round(R * 255) + (Round(G * 255) shl 8) + (Round(B * 255) shl 16) + (Round(A * 255) shl 24);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
+1130
File diff suppressed because it is too large.
Load diff
+87
@@ -0,0 +1,87 @@
|
||||
unit KM_Entity;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
KM_CommonClasses;
|
||||
|
||||
type
|
||||
// Abstract entity (has only the basic properties)
|
||||
TKMEntity = class abstract
|
||||
private
|
||||
fUID: Integer; //unique entity ID
|
||||
protected
|
||||
// Accessing field directly with a getter is a hair faster,
|
||||
// but it is more cumbersome to have 2 getters and we don't need it anyway,
|
||||
// since getting 65k UIDs (in XXL Terrain.Load) speeds up by only 0.05sec
|
||||
function GetUID: Integer; inline;
|
||||
procedure SetUID(aUID: Integer);
|
||||
public
|
||||
constructor Create(aUID: Integer);
|
||||
constructor Load(LoadStream: TKMemoryStream); virtual;
|
||||
procedure Save(SaveStream: TKMemoryStream); virtual;
|
||||
|
||||
property UID: Integer read GetUID;
|
||||
|
||||
function ObjToString(const aSeparator: String = '|'): String; virtual;
|
||||
function ObjToStringShort(const aSeparator: String = '|'): String; virtual;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
SysUtils,
|
||||
KM_Defaults;
|
||||
|
||||
|
||||
{ TKMEntity }
|
||||
constructor TKMEntity.Create(aUID: Integer);
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
fUID := aUID;
|
||||
end;
|
||||
|
||||
|
||||
constructor TKMEntity.Load(LoadStream: TKMemoryStream);
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
LoadStream.CheckMarker('Entity');
|
||||
LoadStream.Read(fUID);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMEntity.Save(SaveStream: TKMemoryStream);
|
||||
begin
|
||||
SaveStream.PlaceMarker('Entity');
|
||||
SaveStream.Write(fUID);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMEntity.SetUID(aUID: Integer);
|
||||
begin
|
||||
fUID := aUID;
|
||||
end;
|
||||
|
||||
|
||||
function TKMEntity.GetUID: Integer;
|
||||
begin
|
||||
if Self = nil then Exit(UID_NONE);
|
||||
|
||||
Result := fUID;
|
||||
end;
|
||||
|
||||
|
||||
function TKMEntity.ObjToStringShort(const aSeparator: String = '|'): String;
|
||||
begin
|
||||
Result := Format('UID = %d', [UID]);
|
||||
end;
|
||||
|
||||
|
||||
function TKMEntity.ObjToString(const aSeparator: String = '|'): String;
|
||||
begin
|
||||
Result := ObjToStringShort(aSeparator);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
+198
@@ -0,0 +1,198 @@
|
||||
unit KM_Lists;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes,
|
||||
SysUtils,
|
||||
KM_CommonTypes;
|
||||
|
||||
type
|
||||
TKMMapsCRCList = class
|
||||
private
|
||||
fEnabled: Boolean;
|
||||
fMapsList: TStringList;
|
||||
fOnMapsUpdate: TUnicodeStringEvent;
|
||||
|
||||
procedure MapsUpdated;
|
||||
function GetCount: Integer;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
procedure LoadFromString(const aString: UnicodeString);
|
||||
function PackToString: UnicodeString;
|
||||
|
||||
property OnMapsUpdate: TUnicodeStringEvent read fOnMapsUpdate write fOnMapsUpdate;
|
||||
property Count: Integer read GetCount;
|
||||
property Enabled: Boolean read fEnabled write fEnabled;
|
||||
|
||||
procedure Clear;
|
||||
procedure RemoveMissing(aMapsCRCArray: TKMCardinalArray);
|
||||
function Contains(aMapCRC: Cardinal): Boolean;
|
||||
procedure Add(aMapCRC: Cardinal);
|
||||
procedure Remove(aMapCRC: Cardinal);
|
||||
procedure Replace(aOldCRC, aNewCRC: Cardinal);
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
const
|
||||
MAPS_CRC_DELIMITER = ':';
|
||||
|
||||
{ TKMMapsCRCList }
|
||||
constructor TKMMapsCRCList.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
fEnabled := True;
|
||||
fMapsList := TStringList.Create;
|
||||
fMapsList.Delimiter := MAPS_CRC_DELIMITER;
|
||||
fMapsList.StrictDelimiter := True; // Requires D2006 or newer.
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMMapsCRCList.Destroy;
|
||||
begin
|
||||
FreeAndNil(fMapsList);
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
function TKMMapsCRCList.GetCount: Integer;
|
||||
begin
|
||||
if not fEnabled then Exit(0);
|
||||
|
||||
Result := fMapsList.Count;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMapsCRCList.MapsUpdated;
|
||||
begin
|
||||
if Assigned(fOnMapsUpdate) then
|
||||
fOnMapsUpdate(PackToString);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMapsCRCList.LoadFromString(const aString: UnicodeString);
|
||||
var
|
||||
I: Integer;
|
||||
mapCRC : Int64;
|
||||
stringList: TStringList;
|
||||
begin
|
||||
if not fEnabled then Exit;
|
||||
|
||||
fMapsList.Clear;
|
||||
stringList := TStringList.Create;
|
||||
stringList.Delimiter := MAPS_CRC_DELIMITER;
|
||||
stringList.DelimitedText := Trim(aString);
|
||||
|
||||
for I := 0 to stringList.Count - 1 do
|
||||
begin
|
||||
if TryStrToInt64(Trim(stringList[I]), mapCRC)
|
||||
and (mapCRC > 0)
|
||||
and not Contains(Cardinal(mapCRC)) then
|
||||
fMapsList.Add(Trim(stringList[I]));
|
||||
end;
|
||||
|
||||
stringList.Free;
|
||||
end;
|
||||
|
||||
|
||||
function TKMMapsCRCList.PackToString: UnicodeString;
|
||||
begin
|
||||
if not fEnabled then Exit('');
|
||||
|
||||
Result := fMapsList.DelimitedText;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMapsCRCList.Clear;
|
||||
begin
|
||||
if not fEnabled then Exit;
|
||||
|
||||
fMapsList.Clear;
|
||||
end;
|
||||
|
||||
|
||||
//Remove missing Favourites Maps from list, check if are of them are presented in the given maps CRC array.
|
||||
procedure TKMMapsCRCList.RemoveMissing(aMapsCRCArray: TKMCardinalArray);
|
||||
|
||||
function ArrayContains(aValue: Cardinal): Boolean;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
for I := Low(aMapsCRCArray) to High(aMapsCRCArray) do
|
||||
if aMapsCRCArray[I] = aValue then
|
||||
begin
|
||||
Result := True;
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
if not fEnabled then Exit;
|
||||
|
||||
I := fMapsList.Count - 1;
|
||||
//We must check, that all values from favorites are presented in maps CRC array. If not - then remove it from favourites
|
||||
while (fMapsList.Count > 0) and (I >= 0) do
|
||||
begin
|
||||
if not ArrayContains(StrToInt64(fMapsList[I])) then
|
||||
begin
|
||||
fMapsList.Delete(I);
|
||||
MapsUpdated;
|
||||
end;
|
||||
|
||||
Dec(I);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMMapsCRCList.Contains(aMapCRC: Cardinal): Boolean;
|
||||
begin
|
||||
if (Self = nil) or not fEnabled then Exit(False);
|
||||
|
||||
Result := fMapsList.IndexOf(IntToStr(aMapCRC)) <> -1;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMapsCRCList.Add(aMapCRC: Cardinal);
|
||||
begin
|
||||
if not fEnabled then Exit;
|
||||
|
||||
if not Contains(aMapCRC) then
|
||||
begin
|
||||
fMapsList.Add(IntToStr(aMapCRC));
|
||||
MapsUpdated;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMapsCRCList.Remove(aMapCRC: Cardinal);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
if not fEnabled then Exit;
|
||||
|
||||
I := fMapsList.IndexOf(IntToStr(aMapCRC));
|
||||
if I <> -1 then
|
||||
fMapsList.Delete(I);
|
||||
|
||||
MapsUpdated;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMapsCRCList.Replace(aOldCRC, aNewCRC: Cardinal);
|
||||
begin
|
||||
if not fEnabled then Exit;
|
||||
|
||||
if Contains(aOldCRC) then
|
||||
begin
|
||||
Remove(aOldCRC);
|
||||
Add(aNewCRC);
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
+1291
File diff suppressed because it is too large.
Load diff
+301
@@ -0,0 +1,301 @@
|
||||
unit KM_WorkerThread;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, SysUtils, Generics.Collections;
|
||||
|
||||
type
|
||||
// FPC 3.2.2 still has problems with TProc and TProc<>
|
||||
// Hence the simplest solution is to excelude this utility unit from DedicatedServer projects
|
||||
{$IFDEF WDC}
|
||||
TKMWorkerThreadTask = class
|
||||
public
|
||||
TaskName: string;
|
||||
Proc: TProc;
|
||||
OnDone: TProc<String>;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
TKMWorkerThread = class(TThread)
|
||||
// FPC 3.2.2 still has problems with TProc and TProc<>
|
||||
// Hence the simplest solution is to excelude this utility unit from DedicatedServer projects
|
||||
{$IFDEF WDC}
|
||||
private
|
||||
fWorkerThreadName: string;
|
||||
fWorkCompleted: Boolean;
|
||||
fTaskQueue: TQueue<TKMWorkerThreadTask>;
|
||||
|
||||
procedure NameThread; overload;
|
||||
procedure NameThread(aThreadName: string); overload;
|
||||
function GetBaseThreadName: string;
|
||||
public
|
||||
//Special mode for exception handling. Runs work synchronously inside QueueWork
|
||||
fSynchronousExceptionMode: Boolean;
|
||||
|
||||
constructor Create(const aThreadName: string = '');
|
||||
destructor Destroy; override;
|
||||
procedure Execute; override;
|
||||
|
||||
procedure QueueWork(aProc: TProc; aTaskName: string = '');
|
||||
// It is a bit odd that we want the callback to return the aTaskName
|
||||
procedure QueueWorkAndCallback(aProc: TProc; aOnDone: TProc<String> = nil; aTaskName: string = '');
|
||||
procedure QueueWorkAndLog(aProc: TProc; aTaskName: string = '');
|
||||
|
||||
procedure WaitForAllWorkToComplete;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
// Holder of WorkerThread
|
||||
// It should manage its state and recreate an instance if needed
|
||||
TKMWorkerThreadHolder = class
|
||||
{$IFDEF WDC}
|
||||
private
|
||||
fWorkerThreadName: string;
|
||||
fWorkerThread: TKMWorkerThread;
|
||||
function GetWorkerThread: TKMWorkerThread;
|
||||
public
|
||||
constructor Create(const aThreadName: String);
|
||||
destructor Destroy; override;
|
||||
|
||||
property Worker: TKMWorkerThread read GetWorkerThread write fWorkerThread;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
KM_Log;
|
||||
|
||||
|
||||
{$IFDEF WDC}
|
||||
{ TKMWorkerThread }
|
||||
constructor TKMWorkerThread.Create(const aThreadName: string = '');
|
||||
begin
|
||||
//Thread isn't started until all constructors have run to completion
|
||||
//so Create(False) may be put in front as well
|
||||
inherited Create(False);
|
||||
|
||||
fWorkerThreadName := aThreadName;
|
||||
|
||||
{$IFDEF DEBUG}
|
||||
if fWorkerThreadName <> '' then
|
||||
TThread.NameThreadForDebugging(fWorkerThreadName, ThreadID);
|
||||
{$ENDIF}
|
||||
|
||||
fWorkCompleted := False;
|
||||
fSynchronousExceptionMode := False;
|
||||
fTaskQueue := TQueue<TKMWorkerThreadTask>.Create;
|
||||
end;
|
||||
|
||||
destructor TKMWorkerThread.Destroy;
|
||||
begin
|
||||
Terminate;
|
||||
//Wake the thread if it's waiting
|
||||
TMonitor.Enter(fTaskQueue);
|
||||
try
|
||||
TMonitor.Pulse(fTaskQueue);
|
||||
finally
|
||||
TMonitor.Exit(fTaskQueue);
|
||||
end;
|
||||
|
||||
inherited Destroy;
|
||||
|
||||
fTaskQueue.Free; // Free task queue after Worker thread is destroyed so we don't wait for it
|
||||
end;
|
||||
|
||||
|
||||
function TKMWorkerThread.GetBaseThreadName: string;
|
||||
begin
|
||||
{$IFDEF DEBUG}
|
||||
Result := fWorkerThreadName + ' Jobs=' + IntToStr(fTaskQueue.Count); // Has to be synced!
|
||||
{$ELSE}
|
||||
Result := '';
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMWorkerThread.NameThread;
|
||||
begin
|
||||
{$IFDEF DEBUG}
|
||||
NameThread(fWorkerThreadName);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMWorkerThread.NameThread(aThreadName: string);
|
||||
begin
|
||||
{$IFDEF DEBUG}
|
||||
if fWorkerThreadName <> '' then
|
||||
TThread.NameThreadForDebugging(aThreadName);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMWorkerThread.Execute;
|
||||
var
|
||||
task: TKMWorkerThreadTask;
|
||||
loopRunning: Boolean;
|
||||
threadName: string;
|
||||
begin
|
||||
task := nil;
|
||||
loopRunning := True;
|
||||
threadName := '';
|
||||
|
||||
while loopRunning do
|
||||
begin
|
||||
TMonitor.Enter(fTaskQueue);
|
||||
try
|
||||
threadName := GetBaseThreadName; // get name under TMonitor, cause we access fTaskQueue
|
||||
if fTaskQueue.Count > 0 then
|
||||
begin
|
||||
task := fTaskQueue.Dequeue;
|
||||
end
|
||||
else
|
||||
begin
|
||||
//We may only terminate once we have finished all our work
|
||||
if Terminated then
|
||||
begin
|
||||
loopRunning := False;
|
||||
end
|
||||
else
|
||||
begin
|
||||
//Notify main thread that worker is idle if it's blocked in WaitForAllWorkToComplete
|
||||
fWorkCompleted := True;
|
||||
TMonitor.Pulse(fTaskQueue);
|
||||
|
||||
TMonitor.Wait(fTaskQueue, 10000);
|
||||
if fTaskQueue.Count > 0 then
|
||||
task := fTaskQueue.Dequeue;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
TMonitor.Exit(fTaskQueue);
|
||||
end;
|
||||
|
||||
if task <> nil then
|
||||
begin
|
||||
NameThread(threadName);
|
||||
task.Proc();
|
||||
|
||||
if Assigned(task.OnDone) then
|
||||
task.OnDone(task.TaskName);
|
||||
|
||||
FreeAndNil(task);
|
||||
end;
|
||||
|
||||
NameThread;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMWorkerThread.QueueWorkAndLog(aProc: TProc; aTaskName: string = '');
|
||||
begin
|
||||
QueueWorkAndCallback(
|
||||
aProc,
|
||||
// aOnDone (aTaskNameInt = aTaskName, we just use a different name to avoid sideeffects)
|
||||
procedure(aTaskNameInt: String)
|
||||
begin
|
||||
gLog.AddTime('Job "%s" is completed', [aTaskNameInt]);
|
||||
end,
|
||||
aTaskName);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMWorkerThread.QueueWork(aProc: TProc; aTaskName: string = '');
|
||||
begin
|
||||
QueueWorkAndCallback(aProc, nil, aTaskName);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMWorkerThread.QueueWorkAndCallback(aProc: TProc; aOnDone: TProc<String> = nil; aTaskName: string = '');
|
||||
var
|
||||
task: TKMWorkerThreadTask;
|
||||
begin
|
||||
if fSynchronousExceptionMode then
|
||||
begin
|
||||
aProc();
|
||||
end
|
||||
else
|
||||
begin
|
||||
if Finished then
|
||||
raise Exception.Create('Worker thread not running in TKMWorkerThread.QueueWork');
|
||||
|
||||
task := TKMWorkerThreadTask.Create;
|
||||
task.Proc := aProc;
|
||||
task.OnDone := aOnDone;
|
||||
task.TaskName := aTaskName;
|
||||
|
||||
TMonitor.Enter(fTaskQueue);
|
||||
try
|
||||
fWorkCompleted := False;
|
||||
fTaskQueue.Enqueue(task);
|
||||
|
||||
TMonitor.Pulse(fTaskQueue);
|
||||
finally
|
||||
TMonitor.Exit(fTaskQueue);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMWorkerThread.WaitForAllWorkToComplete;
|
||||
begin
|
||||
if fSynchronousExceptionMode then
|
||||
Exit;
|
||||
|
||||
TMonitor.Enter(fTaskQueue);
|
||||
try
|
||||
if not fWorkCompleted and not Finished then
|
||||
begin
|
||||
//Wait infinite until worker thread finish his task
|
||||
while not TMonitor.Wait(fTaskQueue, 1000) do ;
|
||||
end;
|
||||
finally
|
||||
TMonitor.Exit(fTaskQueue);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{ TKMWorkerThreadHolder }
|
||||
constructor TKMWorkerThreadHolder.Create(const aThreadName: String);
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
fWorkerThreadName := aThreadName;
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMWorkerThreadHolder.Destroy;
|
||||
begin
|
||||
FreeAndNil(fWorkerThread);
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
// Get working thread instance
|
||||
// Working thread could be Finished, f.e. in case of an error during its execution
|
||||
// Thread is not running in that case after Continue is pressed in madexcept window and has Finished flag
|
||||
// We can call old thread destructor via Free-ing it and then recreate new worker thread.
|
||||
function TKMWorkerThreadHolder.GetWorkerThread: TKMWorkerThread;
|
||||
begin
|
||||
if (fWorkerThread = nil) then
|
||||
// Create new thread
|
||||
fWorkerThread := TKMWorkerThread.Create(fWorkerThreadName)
|
||||
else
|
||||
if fWorkerThread.Finished then
|
||||
begin
|
||||
// Call destructor of an old thread
|
||||
fWorkerThread.Free;
|
||||
// Create new one instead
|
||||
fWorkerThread := TKMWorkerThread.Create(fWorkerThreadName);
|
||||
end;
|
||||
|
||||
Result := fWorkerThread;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
end.
|
||||
|
||||
@@ -0,0 +1,116 @@
|
||||
unit KM_WorkerThreadUtils;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes
|
||||
{$IF DEFINED(WDC) OR (FPC_FULLVERSION >= 30200)}, KM_CommonClasses, KM_WorkerThread {$ENDIF};
|
||||
|
||||
{$IF DEFINED(WDC) OR (FPC_FULLVERSION >= 30200)}
|
||||
procedure AsyncSaveToFileAndFree(var aStream: TKMemoryStream; const aFileName: string; aWorkerThread: TKMWorkerThread);
|
||||
procedure AsyncSaveToFileCompressedAndFree(var aStream: TKMemoryStream; const aFileName: string; const aMarker: string; aWorkerThread: TKMWorkerThread);
|
||||
procedure AsyncSaveStreamsToFileAndFree(var aMainStream, aSubStream1, aSubStream2: TKMemoryStream; const aFileName: string;
|
||||
const aMarker1, aMarker2: string; aWorkerThread: TKMWorkerThread);
|
||||
{$ENDIF}
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
{$IF DEFINED(WDC) OR (FPC_FULLVERSION >= 30200)}
|
||||
procedure AsyncSaveToFileAndFree(var aStream: TKMemoryStream; const aFileName: string; aWorkerThread: TKMWorkerThread);
|
||||
var
|
||||
localStream: TKMemoryStream;
|
||||
begin
|
||||
localStream := aStream;
|
||||
aStream := nil; //So caller doesn't use it by mistake
|
||||
|
||||
{$IFDEF WDC}
|
||||
aWorkerThread.QueueWork(
|
||||
procedure
|
||||
begin
|
||||
try
|
||||
localStream.SaveToFile(aFileName);
|
||||
finally
|
||||
localStream.Free;
|
||||
end;
|
||||
end, 'SaveToFile');
|
||||
{$ELSE}
|
||||
try
|
||||
localStream.SaveToFile(aFileName);
|
||||
finally
|
||||
localStream.Free;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
procedure AsyncSaveToFileCompressedAndFree(var aStream: TKMemoryStream; const aFileName: string; const aMarker: string;
|
||||
aWorkerThread: TKMWorkerThread);
|
||||
var
|
||||
localStream: TKMemoryStream;
|
||||
begin
|
||||
localStream := aStream;
|
||||
aStream := nil; //So caller doesn't use it by mistake
|
||||
|
||||
{$IFDEF WDC}
|
||||
aWorkerThread.QueueWork(
|
||||
procedure
|
||||
begin
|
||||
try
|
||||
localStream.SaveToFileCompressed(aFileName, aMarker);
|
||||
finally
|
||||
localStream.Free;
|
||||
end;
|
||||
end, 'SaveToFileCompressed ' + aMarker);
|
||||
{$ELSE}
|
||||
try
|
||||
localStream.SaveToFileCompressed(aFileName, aMarker);
|
||||
finally
|
||||
localStream.Free;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
|
||||
procedure AsyncSaveStreamsToFileAndFree(var aMainStream, aSubStream1, aSubStream2: TKMemoryStream; const aFileName: string;
|
||||
const aMarker1, aMarker2: string; aWorkerThread: TKMWorkerThread);
|
||||
var
|
||||
localSubStream1, localSubStream2, localMainStream: TKMemoryStream;
|
||||
begin
|
||||
localMainStream := aMainStream;
|
||||
localSubStream1 := aSubStream1;
|
||||
localSubStream2 := aSubStream2;
|
||||
aMainStream := nil; //So caller doesn't use it by mistake
|
||||
aSubStream1 := nil; //So caller doesn't use it by mistake
|
||||
aSubStream2 := nil; //So caller doesn't use it by mistake
|
||||
|
||||
{$IFDEF WDC}
|
||||
aWorkerThread.QueueWork(
|
||||
procedure
|
||||
begin
|
||||
try
|
||||
localMainStream.AppendStream(localSubStream1, aMarker1);
|
||||
localMainStream.AppendStream(localSubStream2, aMarker2);
|
||||
localMainStream.SaveToFile(aFileName);
|
||||
finally
|
||||
localSubStream1.Free;
|
||||
localSubStream2.Free;
|
||||
localMainStream.Free;
|
||||
end;
|
||||
end, 'SaveStreamsToFile ' + aMarker1 + ' ' + aMarker2);
|
||||
{$ELSE}
|
||||
try
|
||||
localMainStream.AppendStream(localSubStream1, aMarker1);
|
||||
localMainStream.AppendStream(localSubStream2, aMarker2);
|
||||
localMainStream.SaveToFile(aFileName);
|
||||
finally
|
||||
localSubStream1.Free;
|
||||
localSubStream2.Free;
|
||||
localMainStream.Free;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
end.
|
||||
|
||||
+2138
File diff suppressed because it is too large.
Load diff
+848
@@ -0,0 +1,848 @@
|
||||
unit KM_ControlsBase;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, Controls,
|
||||
KromOGLUtils,
|
||||
KM_Controls,
|
||||
KM_RenderUI,
|
||||
KM_ResFonts, KM_ResTypes,
|
||||
KM_CommonTypes, KM_Points;
|
||||
|
||||
|
||||
type
|
||||
// Beveled area
|
||||
TKMBevel = class(TKMControl)
|
||||
const
|
||||
DEF_BACK_ALPHA = 0.4;
|
||||
DEF_EDGE_ALPHA = 0.75;
|
||||
public
|
||||
BackAlpha: Single;
|
||||
EdgeAlpha: Single;
|
||||
Color: TKMColor3f;
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer);
|
||||
|
||||
procedure SetDefBackAlpha;
|
||||
procedure SetDefEdgeAlpha;
|
||||
procedure SetDefColor;
|
||||
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
// Rectangle area
|
||||
TKMShape = class(TKMControl)
|
||||
public
|
||||
FillColor: TColor4;
|
||||
LineColor: TColor4; //color of outline
|
||||
LineWidth: Byte;
|
||||
public
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer);
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
// Text Label
|
||||
TKMLabel = class(TKMControl)
|
||||
private
|
||||
fWordWrap: Boolean;
|
||||
fFont: TKMFont;
|
||||
fFontColor: TColor4; //Usually white (self-colored)
|
||||
fCaption: UnicodeString; //Original text
|
||||
fText: UnicodeString; //Reformatted text
|
||||
fTextAlign: TKMTextAlign;
|
||||
fTextVAlign: TKMTextVAlign;
|
||||
fTextSize: TKMPoint;
|
||||
fStrikethrough: Boolean;
|
||||
fTabWidth: Integer;
|
||||
|
||||
procedure SetCaption(const aCaption: UnicodeString);
|
||||
procedure SetWordWrap(aValue: Boolean);
|
||||
procedure ReformatText;
|
||||
procedure SetFont(const Value: TKMFont);
|
||||
protected
|
||||
procedure SetWidth(aValue: Integer); override;
|
||||
|
||||
function GetIsPainted: Boolean; override;
|
||||
public
|
||||
MaxLines: Integer;
|
||||
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; const aCaption: UnicodeString;
|
||||
aFont: TKMFont; aTextAlign: TKMTextAlign); overload;
|
||||
constructor Create(aParent: TKMPanel; aLeft,aTop: Integer; const aCaption: UnicodeString; aFont: TKMFont;
|
||||
aTextAlign: TKMTextAlign); overload;
|
||||
|
||||
function HitTest(X, Y: Integer; aIncludeDisabled: Boolean = False; aIncludeNotHitable: Boolean = False): Boolean; override;
|
||||
procedure SetColor(aColor: Cardinal);
|
||||
|
||||
property WordWrap: Boolean read fWordWrap write SetWordWrap; //Whether to automatically wrap text within given text area width
|
||||
property Caption: UnicodeString read fCaption write SetCaption;
|
||||
property FontColor: TColor4 read fFontColor write fFontColor;
|
||||
property Strikethrough: Boolean read fStrikethrough write fStrikethrough;
|
||||
property TabWidth: Integer read fTabWidth write fTabWidth;
|
||||
property TextSize: TKMPoint read fTextSize;
|
||||
function TextLeft: Integer;
|
||||
property TextVAlign: TKMTextVAlign read fTextVAlign write fTextVAlign;
|
||||
property Font: TKMFont read fFont write SetFont;
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
// Label that is scrolled within an area. Used in Credits
|
||||
TKMLabelScroll = class(TKMLabel)
|
||||
public
|
||||
SmoothScrollToTop: Cardinal; //Delta between this and TimeGetTime affects vertical position
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; const aCaption: UnicodeString; aFont: TKMFont; aTextAlign: TKMTextAlign);
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
// Image
|
||||
TKMImage = class(TKMControl)
|
||||
private
|
||||
fRX: TRXType;
|
||||
fTexID: Word;
|
||||
fFlagColor: TColor4;
|
||||
protected
|
||||
function GetIsPainted: Boolean; override;
|
||||
public
|
||||
ImageAnchors: TKMAnchorsSet;
|
||||
Highlight: Boolean;
|
||||
HighlightOnMouseOver: Boolean;
|
||||
HighlightCoef: Single;
|
||||
Lightness: Single;
|
||||
ClipToBounds: Boolean;
|
||||
Tiled: Boolean;
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aTexID: Word; aRX: TRXType = rxGui;
|
||||
aImageAnchors: TKMAnchorsSet = [anLeft, anTop]);
|
||||
property RX: TRXType read fRX write fRX;
|
||||
property TexID: Word read fTexID write fTexID;
|
||||
property FlagColor: TColor4 read fFlagColor write fFlagColor;
|
||||
function Click: Boolean;
|
||||
procedure ImageStretch;
|
||||
procedure ImageCenter;
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
// Image stack - for army formation view
|
||||
TKMImageStack = class(TKMControl)
|
||||
private
|
||||
fRX: TRXType;
|
||||
fTexID1, fTexID2: Word; //Normal and commander
|
||||
fCount: Integer;
|
||||
fColumns: Integer;
|
||||
fDrawWidth: Integer;
|
||||
fDrawHeight: Integer;
|
||||
fHighlightID: Integer;
|
||||
public
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aTexID1, aTexID2: Word; aRX: TRXType = rxGui);
|
||||
procedure SetCount(aCount, aColumns, aHighlightID: Word);
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
// 3D Button
|
||||
TKMButton = class(TKMControl)
|
||||
private
|
||||
fCaption: UnicodeString;
|
||||
fTextAlign: TKMTextAlign;
|
||||
fStyle: TKMButtonStyle;
|
||||
fRX: TRXType;
|
||||
fAutoHeight: Boolean; //Set button height automatically depending text size (height)
|
||||
procedure InitCommon(aStyle: TKMButtonStyle);
|
||||
procedure SetCaption(const aCaption: UnicodeString);
|
||||
procedure SetAutoHeight(aValue: Boolean);
|
||||
procedure UpdateHeight;
|
||||
public
|
||||
FlagColor: TColor4; //When using an image
|
||||
CapColor: TColor4;
|
||||
Font: TKMFont;
|
||||
MakesSound: Boolean;
|
||||
TexID: Word;
|
||||
CapOffsetX: Shortint;
|
||||
CapOffsetY: Shortint;
|
||||
ShowImageEnabled: Boolean; // show picture as enabled or not (normal or darkened)
|
||||
TextVAlign: TKMTextVAlign;
|
||||
AutoTextPadding: Byte; //text padding for autoHeight
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aTexID: Word; aRX: TRXType;
|
||||
aStyle: TKMButtonStyle); overload;
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; const aCaption: UnicodeString;
|
||||
aStyle: TKMButtonStyle); overload;
|
||||
function Click: Boolean; //Try to click a button and return TRUE if succeded
|
||||
|
||||
property Caption: UnicodeString read fCaption write SetCaption;
|
||||
property AutoHeight: Boolean read fAutoHeight write SetAutoHeight;
|
||||
|
||||
procedure MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
// Common Flat Button
|
||||
TKMButtonFlatCommon = class abstract(TKMControl)
|
||||
private
|
||||
public
|
||||
RX: TRXType;
|
||||
TexID: Word;
|
||||
TexOffsetX: Shortint;
|
||||
TexOffsetY: Shortint;
|
||||
CapOffsetX: Shortint;
|
||||
CapOffsetY: Shortint;
|
||||
Caption: UnicodeString;
|
||||
CapColor: TColor4;
|
||||
FlagColor: TColor4;
|
||||
Font: TKMFont;
|
||||
HideHighlight: Boolean;
|
||||
Clickable: Boolean; //Disables clicking without dimming
|
||||
EdgeAlpha: Single;
|
||||
BackAlpha: Single;
|
||||
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight, aTexID: Integer; aRX: TRXType = rxGui);
|
||||
|
||||
procedure MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
// FlatButton
|
||||
TKMButtonFlat = class(TKMButtonFlatCommon)
|
||||
public
|
||||
Down: Boolean;
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
// FlatButton with Shape on it
|
||||
TKMFlatButtonShape = class(TKMControl)
|
||||
private
|
||||
fCaption: UnicodeString;
|
||||
fFont: TKMFont;
|
||||
fFontHeight: Byte;
|
||||
public
|
||||
Down: Boolean;
|
||||
FontColor: TColor4;
|
||||
ShapeColor: TColor4;
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; const aCaption: UnicodeString; aFont: TKMFont; aShapeColor: TColor4);
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
{$IFDEF MSWindows} Windows, {$ENDIF}
|
||||
{$IFDEF Unix} LCLIntf, LCLType, {$ENDIF}
|
||||
StrUtils, Math,
|
||||
KM_ControlsTypes,
|
||||
KM_Sound,
|
||||
KM_Resource, KM_ResSound, KM_ResSprites,
|
||||
KM_Defaults, KM_CommonUtils,
|
||||
KM_RenderTypes;
|
||||
|
||||
|
||||
{ TKMBevel }
|
||||
constructor TKMBevel.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
|
||||
SetDefBackAlpha;
|
||||
SetDefEdgeAlpha;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMBevel.SetDefBackAlpha;
|
||||
begin
|
||||
BackAlpha := DEF_BACK_ALPHA; //Default value
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMBevel.SetDefEdgeAlpha;
|
||||
begin
|
||||
EdgeAlpha := DEF_EDGE_ALPHA; //Default value
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMBevel.SetDefColor;
|
||||
begin
|
||||
Color := COLOR3F_BLACK; //Default value
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMBevel.Paint;
|
||||
begin
|
||||
inherited;
|
||||
TKMRenderUI.WriteBevel(AbsLeft, AbsTop, Width, Height, Color, EdgeAlpha, BackAlpha);
|
||||
end;
|
||||
|
||||
|
||||
{ TKMShape }
|
||||
constructor TKMShape.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
|
||||
LineWidth := 2;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMShape.Paint;
|
||||
begin
|
||||
inherited;
|
||||
TKMRenderUI.WriteShape(AbsLeft, AbsTop, Width, Height, FillColor);
|
||||
TKMRenderUI.WriteOutline(AbsLeft, AbsTop, Width, Height, LineWidth, LineColor);
|
||||
end;
|
||||
|
||||
|
||||
{ TKMLabel }
|
||||
constructor TKMLabel.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; const aCaption: UnicodeString;
|
||||
aFont: TKMFont; aTextAlign: TKMTextAlign);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
fFont := aFont;
|
||||
fFontColor := $FFFFFFFF;
|
||||
fTextAlign := aTextAlign;
|
||||
fTextVAlign := tvaTop;
|
||||
fWordWrap := False;
|
||||
fTabWidth := FONT_TAB_WIDTH;
|
||||
SetCaption(aCaption);
|
||||
end;
|
||||
|
||||
|
||||
//Same as above but with width/height ommitted, as in most cases we don't know/don't care
|
||||
constructor TKMLabel.Create(aParent: TKMPanel; aLeft, aTop: Integer; const aCaption: UnicodeString; aFont: TKMFont;
|
||||
aTextAlign: TKMTextAlign);
|
||||
begin
|
||||
Create(aParent, aLeft, aTop, 0, 0, aCaption, aFont, aTextAlign);
|
||||
end;
|
||||
|
||||
|
||||
function TKMLabel.TextLeft: Integer;
|
||||
begin
|
||||
case fTextAlign of
|
||||
taLeft: Result := AbsLeft;
|
||||
taCenter: Result := AbsLeft + Round((Width - fTextSize.X) / 2);
|
||||
taRight: Result := AbsLeft + (Width - fTextSize.X);
|
||||
else Result := AbsLeft;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLabel.SetCaption(const aCaption: UnicodeString);
|
||||
begin
|
||||
fCaption := aCaption;
|
||||
ReformatText;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLabel.SetWordWrap(aValue: Boolean);
|
||||
begin
|
||||
fWordWrap := aValue;
|
||||
ReformatText;
|
||||
end;
|
||||
|
||||
|
||||
//Override usual hittest with regard to text alignment
|
||||
function TKMLabel.HitTest(X, Y: Integer; aIncludeDisabled: Boolean = False; aIncludeNotHitable: Boolean = False): Boolean;
|
||||
begin
|
||||
Result := (Hitable or aIncludeNotHitable)
|
||||
and InRange(X, TextLeft, TextLeft + fTextSize.X)
|
||||
and InRange(Y, AbsTop, AbsTop + Height);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLabel.SetColor(aColor: Cardinal);
|
||||
begin
|
||||
fCaption := StripColor(fCaption);
|
||||
Caption := WrapColor(fCaption, aColor);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLabel.SetFont(const Value: TKMFont);
|
||||
begin
|
||||
fFont := Value;
|
||||
ReformatText;
|
||||
end;
|
||||
|
||||
|
||||
// Existing EOLs should be preserved, and new ones added where needed
|
||||
// Keep original intact incase we need to Reformat text once again
|
||||
procedure TKMLabel.ReformatText;
|
||||
var
|
||||
I: Integer;
|
||||
stake: Integer;
|
||||
begin
|
||||
if fWordWrap then
|
||||
fText := gRes.Fonts[fFont].WordWrap(fCaption, Width, True, False)
|
||||
else
|
||||
fText := fCaption;
|
||||
|
||||
// We may need to display only N lines
|
||||
if MaxLines > 0 then
|
||||
begin
|
||||
stake := 0;
|
||||
for I := 1 to MaxLines do
|
||||
begin
|
||||
stake := PosEx(#124, fText, stake+1);
|
||||
if stake = 0 then
|
||||
Break;
|
||||
end;
|
||||
|
||||
if stake > 0 then
|
||||
fText := LeftStr(fText, stake - 1);
|
||||
end;
|
||||
|
||||
fTextSize := gRes.Fonts[fFont].GetTextSize(fText);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLabel.SetWidth(aValue: Integer);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if fWordWrap then
|
||||
ReformatText;
|
||||
end;
|
||||
|
||||
|
||||
function TKMLabel.GetIsPainted: Boolean;
|
||||
begin
|
||||
Result := inherited and (Length(fCaption) > 0 );
|
||||
end;
|
||||
|
||||
|
||||
// Send caption to render
|
||||
procedure TKMLabel.Paint;
|
||||
var
|
||||
t: Integer;
|
||||
col: Cardinal;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if Enabled then
|
||||
col := FontColor
|
||||
else
|
||||
col := $FF888888;
|
||||
|
||||
t := 0;
|
||||
if Height > 0 then
|
||||
begin
|
||||
case fTextVAlign of
|
||||
tvaNone,
|
||||
tvaTop: ;
|
||||
tvaMiddle: t := (Height - fTextSize.Y) div 2;
|
||||
tvaBottom: t := Height - fTextSize.Y;
|
||||
end;
|
||||
end;
|
||||
|
||||
TKMRenderUI.WriteText(AbsLeft, AbsTop + t, Width, fText, fFont, fTextAlign, col, False, False, False, fTabWidth);
|
||||
|
||||
if fStrikethrough then
|
||||
TKMRenderUI.WriteShape(TextLeft, AbsTop + fTextSize.Y div 2 - 2, fTextSize.X, 3, col, $FF000000);
|
||||
end;
|
||||
|
||||
|
||||
{ TKMLabelScroll }
|
||||
constructor TKMLabelScroll.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; const aCaption: UnicodeString; aFont: TKMFont; aTextAlign: TKMTextAlign);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight, aCaption, aFont, aTextAlign);
|
||||
SmoothScrollToTop := 0; //Disabled by default
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMLabelScroll.Paint;
|
||||
var
|
||||
newTop: Integer;
|
||||
col: Cardinal;
|
||||
begin
|
||||
TKMRenderUI.SetupClipY(AbsTop, AbsTop + Height);
|
||||
newTop := EnsureRange(AbsTop + Height - TimeSince(SmoothScrollToTop) div 50, -MINSHORT, MAXSHORT); //Compute delta and shift by it upwards (Credits page)
|
||||
|
||||
if Enabled then
|
||||
col := FontColor
|
||||
else
|
||||
col := $FF888888;
|
||||
|
||||
TKMRenderUI.WriteText(AbsLeft, newTop, Width, fCaption, fFont, fTextAlign, col);
|
||||
TKMRenderUI.ReleaseClipY;
|
||||
end;
|
||||
|
||||
|
||||
{ TKMImage }
|
||||
constructor TKMImage.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aTexID: Word; aRX: TRXType = rxGui;
|
||||
aImageAnchors: TKMAnchorsSet = [anLeft, anTop]);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
fRX := aRX;
|
||||
fTexID := aTexID;
|
||||
fFlagColor := $FFFF00FF;
|
||||
ImageAnchors := aImageAnchors;
|
||||
Highlight := False;
|
||||
HighlightOnMouseOver := False;
|
||||
HighlightCoef := CTRL_HIGHLIGHT_COEF_DEF;
|
||||
end;
|
||||
|
||||
|
||||
function TKMImage.GetIsPainted: Boolean;
|
||||
begin
|
||||
Result := inherited and (TexID <> 0);
|
||||
end;
|
||||
|
||||
|
||||
//DoClick is called by keyboard shortcuts
|
||||
//It's important that Control must be:
|
||||
// IsVisible (can't shortcut invisible/unaccessible button)
|
||||
// Enabled (can't shortcut disabled function, e.g. Halt during fight)
|
||||
function TKMImage.Click: Boolean;
|
||||
begin
|
||||
if Visible and Enabled then
|
||||
begin
|
||||
//Mark self as CtrlOver and CtrlUp, don't mark CtrlDown since MouseUp manually Nils it
|
||||
Parent.MasterControl.CtrlOver := Self;
|
||||
Parent.MasterControl.CtrlUp := Self;
|
||||
if Assigned(OnClick) then OnClick(Self);
|
||||
Result := True; //Click has happened
|
||||
end
|
||||
else
|
||||
Result := False; //No, we couldn't click for Control is unreachable
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMImage.ImageStretch;
|
||||
begin
|
||||
ImageAnchors := [anLeft, anRight, anTop, anBottom]; //Stretch image to fit
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMImage.ImageCenter; //Render image from center
|
||||
begin
|
||||
ImageAnchors := [];
|
||||
end;
|
||||
|
||||
|
||||
{If image area is bigger than image - do center image in it}
|
||||
procedure TKMImage.Paint;
|
||||
var
|
||||
x, y: Integer;
|
||||
col, row: Integer;
|
||||
paintLightness: Single;
|
||||
drawLeft, drawTop: Integer;
|
||||
drawWidth, drawHeight: Integer;
|
||||
begin
|
||||
inherited;
|
||||
if fTexID = 0 then Exit; //No picture to draw
|
||||
|
||||
if ClipToBounds then
|
||||
begin
|
||||
TKMRenderUI.SetupClipX(AbsLeft, AbsLeft + Width);
|
||||
TKMRenderUI.SetupClipY(AbsTop, AbsTop + Height);
|
||||
end;
|
||||
|
||||
paintLightness := Lightness + HighlightCoef * (Byte(HighlightOnMouseOver and (csOver in State)) + Byte(Highlight));
|
||||
|
||||
if Tiled then
|
||||
begin
|
||||
drawWidth := gGFXData[fRX, fTexID].PxWidth;
|
||||
drawHeight := gGFXData[fRX, fTexID].PxHeight;
|
||||
drawLeft := AbsLeft + Width div 2 - drawWidth div 2;
|
||||
drawTop := AbsTop + Height div 2 - drawHeight div 2;
|
||||
|
||||
col := Width div drawWidth + 1;
|
||||
row := Height div drawHeight + 1;
|
||||
for x := -col div 2 to col div 2 do
|
||||
for y := -row div 2 to row div 2 do
|
||||
TKMRenderUI.WritePicture(drawLeft + x * drawWidth, drawTop + y * drawHeight, drawWidth, drawHeight, ImageAnchors, fRX, fTexID, Enabled, fFlagColor, paintLightness);
|
||||
end
|
||||
else
|
||||
TKMRenderUI.WritePicture(AbsLeft, AbsTop, Width, Height, ImageAnchors, fRX, fTexID, Enabled, fFlagColor, paintLightness);
|
||||
|
||||
if ClipToBounds then
|
||||
begin
|
||||
TKMRenderUI.ReleaseClipX;
|
||||
TKMRenderUI.ReleaseClipY;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{ TKMImageStack }
|
||||
constructor TKMImageStack.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aTexID1, aTexID2: Word; aRX: TRXType = rxGui);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
|
||||
fRX := aRX;
|
||||
fTexID1 := aTexID1;
|
||||
fTexID2 := aTexID2;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMImageStack.SetCount(aCount, aColumns, aHighlightID: Word);
|
||||
var
|
||||
aspect: Single;
|
||||
begin
|
||||
fCount := aCount;
|
||||
fColumns := Math.max(1, aColumns);
|
||||
fHighlightID := aHighlightID;
|
||||
|
||||
fDrawWidth := EnsureRange(Width div fColumns, 8, gGFXData[fRX, fTexID1].PxWidth);
|
||||
fDrawHeight := EnsureRange(Height div Ceil(fCount/fColumns), 6, gGFXData[fRX, fTexID1].PxHeight);
|
||||
|
||||
aspect := gGFXData[fRX, fTexID1].PxWidth / gGFXData[fRX, fTexID1].PxHeight;
|
||||
if fDrawHeight * aspect <= fDrawWidth then
|
||||
fDrawWidth := Round(fDrawHeight * aspect)
|
||||
else
|
||||
fDrawHeight := Round(fDrawWidth / aspect);
|
||||
end;
|
||||
|
||||
|
||||
// If image area is bigger than image - do center image in it
|
||||
procedure TKMImageStack.Paint;
|
||||
var
|
||||
I: Integer;
|
||||
offsetX, offsetY, centerX, centerY: SmallInt; //variable parameters
|
||||
texID: Word;
|
||||
begin
|
||||
inherited;
|
||||
if fTexID1 = 0 then Exit; //No picture to draw
|
||||
|
||||
offsetX := Width div fColumns;
|
||||
offsetY := Height div Ceil(fCount / fColumns);
|
||||
|
||||
centerX := (Width - offsetX * (fColumns-1) - fDrawWidth) div 2;
|
||||
centerY := (Height - offsetY * (Ceil(fCount/fColumns) - 1) - fDrawHeight) div 2;
|
||||
|
||||
for I := 0 to fCount - 1 do
|
||||
begin
|
||||
texID := IfThen(I = fHighlightID, fTexID2, fTexId1);
|
||||
|
||||
TKMRenderUI.WritePicture(AbsLeft + centerX + offsetX * (I mod fColumns),
|
||||
AbsTop + centerY + offsetY * (I div fColumns),
|
||||
fDrawWidth, fDrawHeight, [anLeft, anTop, anRight, anBottom], fRX, texID, Enabled);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{ TKMButton }
|
||||
constructor TKMButton.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aTexID: Word; aRX: TRXType;
|
||||
aStyle: TKMButtonStyle);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
|
||||
InitCommon(aStyle);
|
||||
fRX := aRX;
|
||||
TexID := aTexID;
|
||||
end;
|
||||
|
||||
|
||||
{Different version of button, with caption on it instead of image}
|
||||
constructor TKMButton.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; const aCaption: UnicodeString;
|
||||
aStyle: TKMButtonStyle);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
|
||||
InitCommon(aStyle);
|
||||
Caption := aCaption;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMButton.InitCommon(aStyle: TKMButtonStyle);
|
||||
begin
|
||||
TexID := 0;
|
||||
Caption := '';
|
||||
FlagColor := $FFFF00FF;
|
||||
Font := fntMetal;
|
||||
fTextAlign := taCenter; //Thats default everywhere in KaM
|
||||
TextVAlign := tvaMiddle;//tvaNone;
|
||||
fStyle := aStyle;
|
||||
MakesSound := True;
|
||||
ShowImageEnabled := True;
|
||||
AutoHeight := False;
|
||||
AutoTextPadding := 5;
|
||||
CapColor := icWhite;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMButton.UpdateHeight;
|
||||
var
|
||||
textY: Integer;
|
||||
begin
|
||||
if fAutoHeight then
|
||||
begin
|
||||
textY := gRes.Fonts[Font].GetTextSize(Caption).Y;
|
||||
if textY + AutoTextPadding > Height then
|
||||
Height := textY + AutoTextPadding;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMButton.SetCaption(const aCaption: UnicodeString);
|
||||
begin
|
||||
fCaption := aCaption;
|
||||
UpdateHeight;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMButton.SetAutoHeight(aValue: Boolean);
|
||||
begin
|
||||
fAutoHeight := aValue;
|
||||
UpdateHeight;
|
||||
end;
|
||||
|
||||
|
||||
//DoClick is called by keyboard shortcuts
|
||||
//It puts a focus on the button and depresses it if it was DoPress'ed
|
||||
//It's important that Control must be:
|
||||
// Visible (can't shortcut invisible/unaccessible button)
|
||||
// Enabled (can't shortcut disabled function, e.g. Halt during fight)
|
||||
function TKMButton.Click: Boolean;
|
||||
begin
|
||||
if Visible and Enabled then
|
||||
begin
|
||||
//Mark self as CtrlOver and CtrlUp, don't mark CtrlDown since MouseUp manually Nils it
|
||||
Parent.MasterControl.CtrlOver := Self;
|
||||
Parent.MasterControl.CtrlUp := Self;
|
||||
if Assigned(OnClick) then
|
||||
OnClick(Self);
|
||||
Result := True; //Click has happened
|
||||
end
|
||||
else
|
||||
Result := False; //No, we couldn't click for Control is unreachable
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMButton.MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
if Enabled and MakesSound and (csDown in State) then
|
||||
gSoundPlayer.Play(sfxnButtonClick);
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMButton.Paint;
|
||||
var
|
||||
col: TColor4;
|
||||
stateSet: TKMButtonStateSet;
|
||||
textY, top: Integer;
|
||||
begin
|
||||
inherited;
|
||||
stateSet := [];
|
||||
if (csOver in State) and Enabled then
|
||||
stateSet := stateSet + [bsOver];
|
||||
if (csOver in State) and (csDown in State) then
|
||||
stateSet := stateSet + [bsDown];
|
||||
if not Enabled then
|
||||
stateSet := stateSet + [bsDisabled];
|
||||
|
||||
TKMRenderUI.Write3DButton(AbsLeft, AbsTop, Width, Height, fRX, TexID, FlagColor, stateSet, fStyle, ShowImageEnabled);
|
||||
|
||||
if TexID <> 0 then Exit;
|
||||
|
||||
//If disabled then text should be faded
|
||||
col := IfThen(Enabled, CapColor, icGray);
|
||||
|
||||
top := AbsTop + Byte(bsDown in stateSet) + CapOffsetY;
|
||||
|
||||
textY := gRes.Fonts[Font].GetTextSize(Caption).Y;
|
||||
case TextVAlign of
|
||||
tvaNone: Inc(top, (Height div 2) - 7);
|
||||
tvaTop: Inc(top, 2);
|
||||
tvaMiddle: Inc(top, (Height div 2) - (textY div 2) + 2);
|
||||
tvaBottom: Inc(top, Height - textY);
|
||||
end;
|
||||
TKMRenderUI.WriteText(AbsLeft + Byte(bsDown in stateSet) + CapOffsetX, top,
|
||||
Width, Caption, Font, fTextAlign, col);
|
||||
end;
|
||||
|
||||
|
||||
{TKMButtonFlatCommon}
|
||||
constructor TKMButtonFlatCommon.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight, aTexID: Integer; aRX: TRXType = rxGui);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
RX := aRX;
|
||||
TexID := aTexID;
|
||||
FlagColor := $FFFF00FF;
|
||||
CapColor := $FFFFFFFF;
|
||||
Font := fntGame;
|
||||
Clickable := True;
|
||||
EdgeAlpha := BEVEL_EDGE_ALPHA_DEF;
|
||||
BackAlpha := BEVEL_BACK_ALPHA_DEF;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMButtonFlatCommon.MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
if not Clickable then Exit;
|
||||
if Enabled and (csDown in State) then
|
||||
gSoundPlayer.Play(sfxClick);
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMButtonFlatCommon.Paint;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
TKMRenderUI.WriteBevel(AbsLeft, AbsTop, Width, Height, EdgeAlpha, BackAlpha);
|
||||
|
||||
if (csOver in State) and Enabled and not HideHighlight then
|
||||
TKMRenderUI.WriteShape(AbsLeft+1, AbsTop+1, Width-2, Height-2, $40FFFFFF);
|
||||
end;
|
||||
|
||||
|
||||
//Simple version of button, with a caption and image
|
||||
{TKMButtonFlat}
|
||||
procedure TKMButtonFlat.Paint;
|
||||
var
|
||||
textCol: TColor4;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if TexID <> 0 then
|
||||
TKMRenderUI.WritePicture(AbsLeft + TexOffsetX,
|
||||
AbsTop + TexOffsetY - 6 * Byte(Caption <> ''),
|
||||
Width, Height, [], RX, TexID, Enabled or fEnabledVisually, FlagColor);
|
||||
|
||||
textCol := IfThen(Enabled or fEnabledVisually, CapColor, icGray);
|
||||
TKMRenderUI.WriteText(AbsLeft + CapOffsetX, AbsTop + (Height div 2) + 4 + CapOffsetY, Width, Caption, Font, taCenter, textCol);
|
||||
|
||||
if Down then
|
||||
TKMRenderUI.WriteOutline(AbsLeft, AbsTop, Width, Height, 1, $FFFFFFFF);
|
||||
{if not fEnabled then
|
||||
TKMRenderUI.WriteShape(Left, Top, Width, Height, $80000000);}
|
||||
end;
|
||||
|
||||
|
||||
{ TKMFlatButtonShape }
|
||||
constructor TKMFlatButtonShape.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; const aCaption: UnicodeString; aFont: TKMFont; aShapeColor: TColor4);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
fCaption := aCaption;
|
||||
ShapeColor := aShapeColor;
|
||||
fFont := aFont;
|
||||
fFontHeight := gRes.Fonts[fFont].BaseHeight + 2;
|
||||
FontColor := icWhite;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMFlatButtonShape.Paint;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
TKMRenderUI.WriteBevel(AbsLeft, AbsTop, Width, Height);
|
||||
|
||||
//Shape within bevel
|
||||
TKMRenderUI.WriteShape(AbsLeft + 1, AbsTop + 1, Width - 2, Width - 2, ShapeColor);
|
||||
|
||||
TKMRenderUI.WriteText(AbsLeft, AbsTop + (Height - fFontHeight) div 2,
|
||||
Width, fCaption, fFont, taCenter, FontColor);
|
||||
|
||||
if (csOver in State) and Enabled then
|
||||
TKMRenderUI.WriteShape(AbsLeft + 1, AbsTop + 1, Width - 2, Height - 2, $40FFFFFF);
|
||||
|
||||
if (csDown in State) or Down then
|
||||
TKMRenderUI.WriteOutline(AbsLeft, AbsTop, Width, Height, 1, icWhite);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
+519
@@ -0,0 +1,519 @@
|
||||
unit KM_ControlsChart;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, Controls,
|
||||
KromOGLUtils,
|
||||
KM_Controls,
|
||||
KM_RenderUI, KM_ResFonts,
|
||||
KM_CommonClasses, KM_CommonTypes, KM_Points, KM_Defaults;
|
||||
|
||||
|
||||
type
|
||||
TKMNotifyLegendClick = procedure(Sender: TObject; aLineIndex: Integer; aLineVisible: Boolean) of object;
|
||||
|
||||
TKMGraphLine = record
|
||||
Title: UnicodeString;
|
||||
TitleDetailed: TKMStringArray;
|
||||
TitleDetailedColor: TKMCardinalArray;
|
||||
Tag: Integer;
|
||||
Color: TColor4;
|
||||
Visible: Boolean;
|
||||
Values: TKMCardinalArray;
|
||||
ValuesAlt: TKMCardinalArray;
|
||||
end;
|
||||
|
||||
TKMChart = class(TKMControl)
|
||||
private
|
||||
fCaption: UnicodeString;
|
||||
fFont: TKMFont;
|
||||
fCount: Integer;
|
||||
fItemHeight: Byte;
|
||||
fLegendWidth: Word;
|
||||
fLegendCaption: String;
|
||||
fLineOver: Integer;
|
||||
fLines: array of TKMGraphLine;
|
||||
fMaxLength: Cardinal; //Maximum samples (by horizontal axis)
|
||||
fMinTime: Cardinal; //Minimum time (in sec), used only for Rendering time ticks
|
||||
fMaxTime: Cardinal; //Maximum time (in sec), used only for Rendering time ticks
|
||||
fMaxValue: Cardinal; //Maximum value (by vertical axis)
|
||||
fPeaceTime: Cardinal;
|
||||
|
||||
//Legend separators
|
||||
fSeparatorPositions: TXStringList;
|
||||
fSeparatorHeight: Byte;
|
||||
fSeparatorColor: TColor4;
|
||||
|
||||
fOnLegendClick: TKMNotifyLegendClick;
|
||||
procedure UpdateMaxValue;
|
||||
function GetLine(aIndex:Integer): TKMGraphLine;
|
||||
function GetLineNumber(aY: Integer): Integer;
|
||||
// function GetSeparatorsHeight(aIndex: Integer): Integer;
|
||||
function GetSeparatorPos(aIndex: Integer): Integer;
|
||||
public
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer);
|
||||
destructor Destroy; override;
|
||||
|
||||
procedure AddLine(const aTitle: UnicodeString; aColor: TColor4; const aValues: TKMCardinalArray; aTag: Integer = -1); overload;
|
||||
procedure AddLine(const aTitle: UnicodeString; aColor: TColor4; const aTitleDetailed: TKMStringArray;
|
||||
const aTitleDetailedColor: TKMCardinalArray; const aValues: TKMCardinalArray; aTag: Integer = -1); overload;
|
||||
procedure AddAltLine(const aAltValues: TKMCardinalArray);
|
||||
procedure TrimToFirstVariation;
|
||||
property Caption: UnicodeString read fCaption write fCaption;
|
||||
procedure Clear;
|
||||
procedure SetLineVisible(aLineID:Integer; aVisible:Boolean);
|
||||
property MaxLength: Cardinal read fMaxLength write fMaxLength;
|
||||
property MaxTime: Cardinal read fMaxTime write fMaxTime;
|
||||
property Lines[aIndex: Integer]: TKMGraphLine read GetLine;
|
||||
property LineCount:Integer read fCount;
|
||||
property Font: TKMFont read fFont write fFont;
|
||||
property LegendWidth: Word read fLegendWidth write fLegendWidth;
|
||||
property LegendCaption: String read fLegendCaption write fLegendCaption;
|
||||
property Peacetime: Cardinal read fPeaceTime write fPeaceTime;
|
||||
|
||||
property SeparatorPos[aIndex: Integer]: Integer read GetSeparatorPos;
|
||||
property SeparatorColor: TColor4 read fSeparatorColor write fSeparatorColor;
|
||||
property SeparatorHeight: Byte read fSeparatorHeight write fSeparatorHeight;
|
||||
|
||||
procedure AddSeparator(aPosition: Integer);
|
||||
procedure SetSeparatorPositions(aSeparatorPositions: TStringList);
|
||||
procedure ClearSeparators;
|
||||
|
||||
property OnLegendClick: TKMNotifyLegendClick read fOnLegendClick write fOnLegendClick;
|
||||
|
||||
procedure MouseMove(X,Y: Integer; Shift: TShiftState); override;
|
||||
procedure MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
SysUtils, Math,
|
||||
KM_Resource, KM_ResTexts,
|
||||
KM_CommonUtils;
|
||||
|
||||
|
||||
{ TKMChart }
|
||||
constructor TKMChart.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
|
||||
fSeparatorPositions := TXStringList.Create;
|
||||
fSeparatorPositions.Sorted := True; // Better we have separators sorted
|
||||
|
||||
fFont := fntOutline;
|
||||
fItemHeight := 20;
|
||||
fLineOver := -1;
|
||||
fLegendWidth := 150;
|
||||
fSeparatorColor := clChartSeparator;
|
||||
fSeparatorHeight := 10;
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMChart.Destroy;
|
||||
begin
|
||||
FreeAndNil(fSeparatorPositions);
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMChart.AddLine(const aTitle: UnicodeString; aColor: TColor4; const aValues: TKMCardinalArray; aTag: Integer = -1);
|
||||
var
|
||||
titleDetailed: TKMStringArray;
|
||||
titleDetailedColor: TKMCardinalArray;
|
||||
begin
|
||||
SetLength(titleDetailed, 0);
|
||||
SetLength(titleDetailedColor, 0);
|
||||
AddLine(aTitle, aColor, titleDetailed, titleDetailedColor, aValues, aTag);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMChart.AddLine(const aTitle: UnicodeString; aColor: TColor4; const aTitleDetailed: TKMStringArray;
|
||||
const aTitleDetailedColor: TKMCardinalArray; const aValues: TKMCardinalArray; aTag: Integer = -1);
|
||||
begin
|
||||
if fMaxLength = 0 then Exit;
|
||||
|
||||
Assert(Length(aTitleDetailed) = Length(aTitleDetailedColor), 'aTitleDetailed and aTitleDetailedColor should have same length');
|
||||
|
||||
//Make sure there is enough Values to copy to local storage with Move procedure
|
||||
Assert(Length(aValues) >= fMaxLength);
|
||||
|
||||
SetLength(fLines, fCount + 1);
|
||||
|
||||
fLines[fCount].Color := aColor;
|
||||
fLines[fCount].Title := aTitle;
|
||||
fLines[fCount].Tag := aTag;
|
||||
fLines[fCount].Visible := True;
|
||||
fLines[fCount].TitleDetailed := aTitleDetailed;
|
||||
fLines[fCount].TitleDetailedColor := aTitleDetailedColor;
|
||||
SetLength(fLines[fCount].Values, fMaxLength);
|
||||
if SizeOf(aValues) <> 0 then
|
||||
Move(aValues[0], fLines[fCount].Values[0], SizeOf(aValues[0]) * fMaxLength);
|
||||
Inc(fCount);
|
||||
|
||||
UpdateMaxValue;
|
||||
end;
|
||||
|
||||
|
||||
function TKMChart.GetSeparatorPos(aIndex: Integer): Integer;
|
||||
begin
|
||||
Result := -1;
|
||||
if not InRange(aIndex, 0, fSeparatorPositions.Count - 1) then Exit;
|
||||
|
||||
Result := StrToInt(fSeparatorPositions[aIndex]);
|
||||
end;
|
||||
|
||||
|
||||
//function TKMChart.GetSeparatorsHeight(aIndex: Integer): Integer;
|
||||
//var
|
||||
// I, Pos: Integer;
|
||||
//begin
|
||||
// Result := 0;
|
||||
// for I := 0 to fSeparatorPositions.Count - 1 do
|
||||
// begin
|
||||
// Pos := SeparatorPos[I];
|
||||
// if (Pos <> -1) and (Pos <= aIndex) then
|
||||
// Inc(Result, fSeparatorHeight);
|
||||
// end;
|
||||
//end;
|
||||
|
||||
|
||||
procedure TKMChart.AddSeparator(aPosition: Integer);
|
||||
begin
|
||||
fSeparatorPositions.Add(IntToStr(aPosition));
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMChart.SetSeparatorPositions(aSeparatorPositions: TStringList);
|
||||
begin
|
||||
fSeparatorPositions.Clear;
|
||||
fSeparatorPositions.AddStrings(aSeparatorPositions);
|
||||
end;
|
||||
|
||||
|
||||
//Add alternative values line (e.g. wares count vs. wares produced)
|
||||
procedure TKMChart.AddAltLine(const aAltValues: TKMCardinalArray);
|
||||
begin
|
||||
Assert(Length(aAltValues) >= fMaxLength);
|
||||
|
||||
SetLength(fLines[fCount-1].ValuesAlt, fMaxLength);
|
||||
if SizeOf(aAltValues) <> 0 then
|
||||
Move(aAltValues[0], fLines[fCount-1].ValuesAlt[0], SizeOf(aAltValues[0]) * fMaxLength);
|
||||
|
||||
UpdateMaxValue;
|
||||
end;
|
||||
|
||||
|
||||
//Trims the graph until 5% before the first variation
|
||||
procedure TKMChart.TrimToFirstVariation;
|
||||
var
|
||||
I, K, firstVarSample: Integer;
|
||||
startVal: Cardinal;
|
||||
begin
|
||||
firstVarSample := -1;
|
||||
for I:=0 to fCount-1 do
|
||||
if Length(fLines[I].Values) > 0 then
|
||||
begin
|
||||
startVal := fLines[I].Values[0];
|
||||
for K:=1 to Length(fLines[I].Values)-1 do
|
||||
if fLines[I].Values[K] <> startVal then
|
||||
begin
|
||||
if (K < firstVarSample) or (firstVarSample = -1) then
|
||||
firstVarSample := K - 1;
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
if firstVarSample <= 0 then
|
||||
begin
|
||||
fMinTime := 0; //No variation at all, so don't trim it (but clear previous value)
|
||||
Exit;
|
||||
end;
|
||||
//Take 5% before the first varied sample
|
||||
firstVarSample := Max(0, firstVarSample - Max(1, Round(0.05*(fMaxLength - firstVarSample))));
|
||||
//Trim all fLines[I].Values to start at FirstVarSample
|
||||
for I := 0 to fCount - 1 do
|
||||
begin
|
||||
Move(fLines[I].Values[firstVarSample], fLines[I].Values[0], (Length(fLines[I].Values)-firstVarSample)*SizeOf(fLines[I].Values[0]));
|
||||
SetLength(fLines[I].Values, Length(fLines[I].Values)-firstVarSample);
|
||||
end;
|
||||
//Set start time so the horizontal time ticks are rendered correctly
|
||||
fMinTime := Round((firstVarSample/fMaxLength) * fMaxTime);
|
||||
//All lines have now been trimmed, so update fMaxLength
|
||||
fMaxLength := fMaxLength - firstVarSample;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMChart.Clear;
|
||||
begin
|
||||
fCount := 0;
|
||||
SetLength(fLines, 0);
|
||||
fMaxValue := 0;
|
||||
ClearSeparators;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMChart.ClearSeparators;
|
||||
begin
|
||||
fSeparatorPositions.Clear;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMChart.SetLineVisible(aLineID: Integer; aVisible: Boolean);
|
||||
begin
|
||||
fLines[aLineID].Visible := aVisible;
|
||||
UpdateMaxValue;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMChart.UpdateMaxValue;
|
||||
var
|
||||
I, K: Integer;
|
||||
begin
|
||||
fMaxValue := 0;
|
||||
for I := 0 to fCount - 1 do
|
||||
if fLines[I].Visible then
|
||||
for K := 0 to fMaxLength - 1 do
|
||||
if fLines[I].Values[K] > fMaxValue then
|
||||
fMaxValue := fLines[I].Values[K];
|
||||
end;
|
||||
|
||||
|
||||
function TKMChart.GetLine(aIndex: Integer): TKMGraphLine;
|
||||
begin
|
||||
Result := fLines[aIndex];
|
||||
end;
|
||||
|
||||
|
||||
function TKMChart.GetLineNumber(aY: Integer): Integer;
|
||||
var
|
||||
I, S, lineTop, lineBottom: Integer;
|
||||
begin
|
||||
Result := -1;
|
||||
S := 0;
|
||||
lineTop := AbsTop + 5 + 20*Byte(fLegendCaption <> '');
|
||||
for I := 0 to fCount - 1 do
|
||||
begin
|
||||
if SeparatorPos[S] = I then
|
||||
begin
|
||||
Inc(lineTop, fSeparatorHeight);
|
||||
Inc(S);
|
||||
end;
|
||||
lineBottom := lineTop + fItemHeight*(1 + Length(Lines[I].TitleDetailed));
|
||||
if InRange(aY, lineTop, lineBottom) then
|
||||
begin
|
||||
Result := I;
|
||||
Exit;
|
||||
end;
|
||||
lineTop := lineBottom;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMChart.MouseMove(X, Y: Integer; Shift: TShiftState);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
fLineOver := -1;
|
||||
if X < AbsLeft + Width - fLegendWidth + 5 then Exit;
|
||||
fLineOver := GetLineNumber(Y);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMChart.MouseUp(X, Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if X < AbsLeft + Width - fLegendWidth+5 then Exit;
|
||||
|
||||
I := GetLineNumber(Y);
|
||||
if not InRange(I, 0, fCount - 1) then Exit;
|
||||
|
||||
fLines[I].Visible := not fLines[I].Visible;
|
||||
|
||||
UpdateMaxValue;
|
||||
|
||||
if Assigned(fOnLegendClick) then
|
||||
fOnLegendClick(Self, I, fLines[I].Visible);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMChart.Paint;
|
||||
const
|
||||
INTERVAL_CNT: array [0..9] of Word = (1, 5, 10, 50, 100, 500, 1000, 5000, 10000, 50000);
|
||||
INTERVAL_TIME: array [0..10] of Word = (30, 1*60, 5*60, 10*60, 15*60, 30*60, 1*60*60, 2*60*60, 3*60*60, 4*60*60, 5*60*60);
|
||||
|
||||
var
|
||||
G: TKMRect;
|
||||
topValue: Integer;
|
||||
|
||||
procedure PaintAxisLabel(aTime: Integer; aIsPT: Boolean = False);
|
||||
var
|
||||
xPos: Integer;
|
||||
begin
|
||||
xPos := G.Left + Round((aTime - fMinTime) / (fMaxTime-fMinTime) * (G.Right - G.Left));
|
||||
TKMRenderUI.WriteShape(xPos, G.Bottom - 2, 2, 5, IfThen(aIsPT, clChartPeacetimeLn, icWhite));
|
||||
TKMRenderUI.WriteText (xPos, G.Bottom + 4, 0, TimeToString(aTime / 24 / 60 / 60), fntGame, taLeft, IfThen(aIsPT, clChartPeacetimeLbl, icWhite));
|
||||
TKMRenderUI.WriteLine(xPos, G.Top, xPos, G.Bottom, IfThen(aIsPT, clChartPeacetimeLn, clChartDashedVLn), $CCCC);
|
||||
if aIsPT then
|
||||
TKMRenderUI.WriteText(xPos - 3, G.Bottom + 4, 0, gResTexts[TX_CHART_PT_END], fntGame, taRight, clChartPeacetimeLbl);
|
||||
end;
|
||||
|
||||
procedure RenderHorizontalAxisTicks;
|
||||
var
|
||||
I, best: Integer;
|
||||
begin
|
||||
//Find first time interval that will have less than 10 ticks
|
||||
best := 0;
|
||||
for I := Low(INTERVAL_TIME) to High(INTERVAL_TIME) do
|
||||
if (fMaxTime-fMinTime) div INTERVAL_TIME[I] < 7 then
|
||||
begin
|
||||
best := INTERVAL_TIME[I];
|
||||
Break;
|
||||
end;
|
||||
|
||||
//Paint time axis labels
|
||||
if (best <> 0) and (fMaxTime <> fMinTime) then
|
||||
if (fPeaceTime <> 0) and InRange(fPeaceTime, fMinTime, fMaxTime) then
|
||||
begin
|
||||
//Labels before PT and PT himself
|
||||
for I := 0 to ((fPeaceTime - fMinTime) div best) do
|
||||
PaintAxisLabel(fPeaceTime - I * best, I = 0);
|
||||
|
||||
//Labels after PT
|
||||
for I := 1 to ((fMaxTime - fPeaceTime) div best) do
|
||||
PaintAxisLabel(fPeaceTime + I * best);
|
||||
end else
|
||||
for I := Ceil(fMinTime / best) to (fMaxTime div best) do
|
||||
PaintAxisLabel(I * best);
|
||||
end;
|
||||
|
||||
function GetLineColor(aColor: Cardinal): Cardinal;
|
||||
begin
|
||||
//Adjust the color if it blends with black background
|
||||
Result := EnsureBrightness(aColor, 0.3);
|
||||
|
||||
// If color is similar to highlight color, then use alternative HL color
|
||||
if GetColorDistance(Result, clChartHighlight) < 0.1 then
|
||||
Result := clChartHighlight2;
|
||||
end;
|
||||
|
||||
procedure RenderChartAndLegend;
|
||||
const
|
||||
MARKS_FONT: TKMFont = fntGrey;
|
||||
var
|
||||
I, J, S, checkSize, xPos, yPos, height: Integer;
|
||||
titleDetailedH: Integer;
|
||||
newColor: TColor4;
|
||||
begin
|
||||
checkSize := gRes.Fonts[MARKS_FONT].GetTextSize('v').Y + 1;
|
||||
S := 0;
|
||||
xPos := G.Right + 10;
|
||||
yPos := G.Top + 8 + 20*Byte(fLegendCaption <> '');
|
||||
|
||||
titleDetailedH := 0;
|
||||
//Charts and legend
|
||||
for I := 0 to fCount - 1 do
|
||||
begin
|
||||
newColor := GetLineColor(fLines[I].Color);
|
||||
|
||||
if (csOver in State) and (I = fLineOver) then
|
||||
newColor := clChartHighlight;
|
||||
|
||||
//Charts
|
||||
if fLines[I].Visible then
|
||||
begin
|
||||
TKMRenderUI.WritePlot(G.Left, G.Top, G.Right-G.Left, G.Bottom-G.Top, fLines[I].Values, topValue, newColor, 2);
|
||||
if Length(fLines[I].ValuesAlt) > 0 then
|
||||
TKMRenderUI.WritePlot(G.Left, G.Top, G.Right-G.Left, G.Bottom-G.Top, fLines[I].ValuesAlt, topValue, newColor, 1);
|
||||
end;
|
||||
|
||||
if SeparatorPos[S] = I then
|
||||
begin
|
||||
Inc(yPos, fSeparatorHeight);
|
||||
Inc(S);
|
||||
end;
|
||||
|
||||
//Checkboxes
|
||||
TKMRenderUI.WriteBevel(xPos, yPos, checkSize - 4, checkSize - 4, 1, 0.3);
|
||||
TKMRenderUI.WriteOutline(xPos, yPos, checkSize - 4, checkSize - 4, 1, clChkboxOutline);
|
||||
if fLines[I].Visible then
|
||||
TKMRenderUI.WriteText(xPos + (checkSize-4) div 2, yPos - 1, 0, 'v', MARKS_FONT, taCenter, newColor);
|
||||
|
||||
//Legend
|
||||
TKMRenderUI.WriteText(xPos + checkSize, yPos, 0, fLines[I].Title, fntGame, taLeft, newColor);
|
||||
Inc(yPos, fItemHeight);
|
||||
|
||||
//Detailed legend
|
||||
for J := Low(fLines[I].TitleDetailed) to High(fLines[I].TitleDetailed) do
|
||||
begin
|
||||
TKMRenderUI.WriteText(xPos + checkSize + 5, yPos, 0, fLines[I].TitleDetailed[J], fntGrey, taLeft, GetLineColor(fLines[I].TitleDetailedColor[J]));
|
||||
Inc(yPos, fItemHeight);
|
||||
Inc(titleDetailedH, fItemHeight);
|
||||
end;
|
||||
end;
|
||||
|
||||
//Legend title and outline
|
||||
height := fItemHeight*fCount + titleDetailedH + 6 + 20*Byte(fLegendCaption <> '') + fSeparatorPositions.Count*fSeparatorHeight;
|
||||
TKMRenderUI.WriteShape(G.Right + 5, G.Top, fLegendWidth, height, icDarkestGrayTrans);
|
||||
TKMRenderUI.WriteOutline(G.Right + 5, G.Top, fLegendWidth, height, 1, icGray);
|
||||
if fLegendCaption <> '' then
|
||||
TKMRenderUI.WriteText(G.Right + 5, G.Top + 4, fLegendWidth, fLegendCaption, fntMetal, taCenter, icWhite);
|
||||
end;
|
||||
|
||||
var
|
||||
I: Integer;
|
||||
best, tmp: Integer;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
G := KMRect(AbsLeft + 40, AbsTop, AbsLeft + Width - fLegendWidth, AbsTop + Height - 20);
|
||||
|
||||
//Add margin to MaxValue so that it does not blends with upper border
|
||||
topValue := Max(Round(fMaxValue * 1.1), fMaxValue + 1);
|
||||
|
||||
//Find first interval that will have less than 10 ticks
|
||||
best := 0;
|
||||
for I := Low(INTERVAL_CNT) to High(INTERVAL_CNT) do
|
||||
if topValue div INTERVAL_CNT[I] < 10 then
|
||||
begin
|
||||
best := INTERVAL_CNT[I];
|
||||
Break;
|
||||
end;
|
||||
|
||||
//Dashed lines in the background
|
||||
if best <> 0 then
|
||||
for I := 1 to (topValue div best) do
|
||||
begin
|
||||
tmp := G.Top + Round((1 - I * best / topValue) * (G.Bottom - G.Top));
|
||||
TKMRenderUI.WriteText(G.Left - 5, tmp - 6, 0, IntToStr(I * best), fntGame, taRight);
|
||||
TKMRenderUI.WriteLine(G.Left, tmp, G.Right, tmp, clChartDashedHLn, $CCCC);
|
||||
end;
|
||||
|
||||
//Render horizontal axis ticks
|
||||
RenderHorizontalAxisTicks;
|
||||
|
||||
RenderChartAndLegend;
|
||||
|
||||
//Render the highlighted line above all the others and thicker so you can see where it goes under others
|
||||
if (csOver in State) and InRange(fLineOver, 0, fCount-1) and fLines[fLineOver].Visible then
|
||||
TKMRenderUI.WritePlot(G.Left, G.Top, G.Right-G.Left, G.Bottom-G.Top, fLines[fLineOver].Values, topValue, clChartHighlight, 3);
|
||||
|
||||
//Outline
|
||||
TKMRenderUI.WriteOutline(G.Left, G.Top, G.Right-G.Left, G.Bottom-G.Top, 1, icWhite);
|
||||
|
||||
//Title
|
||||
TKMRenderUI.WriteText(G.Left + 5, G.Top + 5, 0, fCaption, fFont, taLeft);
|
||||
|
||||
//Render vertical axis captions
|
||||
TKMRenderUI.WriteText(G.Left - 5, G.Bottom - 6, 0, IntToStr(0), fntGame, taRight);
|
||||
//TKMRenderUI.WriteText(Left+20, Top + 20, 0, 0, IntToStr(fMaxValue), fntGame, taRight);
|
||||
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
+152
@@ -0,0 +1,152 @@
|
||||
unit KM_ControlsColor;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, Controls,
|
||||
KromOGLUtils,
|
||||
KM_Controls, KM_ControlsBase,
|
||||
KM_CommonTypes;
|
||||
|
||||
|
||||
type
|
||||
// Color swatch - to select a color from given samples/palette
|
||||
TKMColorSwatch = class(TKMControl)
|
||||
private
|
||||
fBackAlpha: single; // Alpha of background (usually 0.5, dropbox 1)
|
||||
fCellSize: Byte; // Size of the square in pixels
|
||||
fColumnCount: Byte;
|
||||
fRowCount: Byte;
|
||||
fColorIndex: Integer;
|
||||
Colors: array of TColor4;
|
||||
fOnChange: TNotifyEvent;
|
||||
fInclRandom: Boolean;
|
||||
public
|
||||
constructor Create(aParent: TKMPanel; aLeft,aTop,aColumnCount,aRowCount,aSize: Integer);
|
||||
procedure SetColors(const aColors: array of TColor4; aInclRandom: Boolean = False);
|
||||
procedure SelectByColor(aColor: TColor4);
|
||||
property BackAlpha: single read fBackAlpha write fBackAlpha;
|
||||
property ColorIndex: Integer read fColorIndex write fColorIndex;
|
||||
function GetColor: TColor4;
|
||||
procedure MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
property OnChange: TNotifyEvent write fOnChange;
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Math,
|
||||
KM_RenderUI,
|
||||
KM_ResFonts, KM_ResTypes,
|
||||
KM_CommonUtils;
|
||||
|
||||
|
||||
{ TKMColorSwatch }
|
||||
constructor TKMColorSwatch.Create(aParent: TKMPanel; aLeft,aTop,aColumnCount,aRowCount,aSize: Integer);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, 0, 0);
|
||||
|
||||
fBackAlpha := 0.5;
|
||||
fColumnCount := aColumnCount;
|
||||
fRowCount := aRowCount;
|
||||
fCellSize := aSize;
|
||||
fInclRandom := False;
|
||||
fColorIndex := -1;
|
||||
|
||||
Width := fColumnCount * fCellSize;
|
||||
Height := fRowCount * fCellSize;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMColorSwatch.SetColors(const aColors: array of TColor4; aInclRandom: Boolean = False);
|
||||
begin
|
||||
fInclRandom := aInclRandom;
|
||||
if fInclRandom then
|
||||
begin
|
||||
SetLength(Colors, Length(aColors)+SizeOf(TColor4));
|
||||
Colors[0] := $00000000; //This one is reserved for random
|
||||
Move((@aColors[0])^, (@Colors[1])^, SizeOf(aColors));
|
||||
end
|
||||
else
|
||||
begin
|
||||
SetLength(Colors, Length(aColors));
|
||||
Move((@aColors[0])^, (@Colors[0])^, SizeOf(aColors));
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMColorSwatch.SelectByColor(aColor: TColor4);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
fColorIndex := -1;
|
||||
for I:=0 to Length(Colors)-1 do
|
||||
if Colors[I] = aColor then
|
||||
fColorIndex := I;
|
||||
end;
|
||||
|
||||
|
||||
function TKMColorSwatch.GetColor: TColor4;
|
||||
begin
|
||||
if fColorIndex <> -1 then
|
||||
Result := Colors[fColorIndex]
|
||||
else
|
||||
Result := $FF000000; //Black by default
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMColorSwatch.MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
var
|
||||
newColor: Integer;
|
||||
begin
|
||||
if Button = mbLeft then
|
||||
begin
|
||||
newColor := EnsureRange((Y-AbsTop) div fCellSize, 0, fRowCount-1)*fColumnCount +
|
||||
EnsureRange((X-AbsLeft) div fCellSize, 0, fColumnCount-1);
|
||||
if InRange(newColor, 0, Length(Colors)-1) then
|
||||
begin
|
||||
fColorIndex := newColor;
|
||||
if Assigned(fOnChange) then fOnChange(Self);
|
||||
end;
|
||||
end;
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMColorSwatch.Paint;
|
||||
var
|
||||
I, start: Integer;
|
||||
selColor: TColor4;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
TKMRenderUI.WriteBevel(AbsLeft, AbsTop, Width, Height, 1, fBackAlpha);
|
||||
|
||||
start := 0;
|
||||
if fInclRandom then
|
||||
begin
|
||||
//Render miniature copy of all available colors with '?' on top
|
||||
for I := 0 to Length(Colors) - 1 do
|
||||
TKMRenderUI.WriteShape(AbsLeft+(I mod fColumnCount)*(fCellSize div fColumnCount)+2, AbsTop+(I div fColumnCount)*(fCellSize div fColumnCount)+2, (fCellSize div fColumnCount), (fCellSize div fColumnCount), Colors[I]);
|
||||
TKMRenderUI.WriteText(AbsLeft + fCellSize div 2, AbsTop + fCellSize div 4, 0, '?', fntMetal, taCenter);
|
||||
start := 1;
|
||||
end;
|
||||
|
||||
for I := start to Length(Colors) - 1 do
|
||||
TKMRenderUI.WriteShape(AbsLeft+(I mod fColumnCount)*fCellSize, AbsTop+(I div fColumnCount)*fCellSize, fCellSize, fCellSize, Colors[I]);
|
||||
|
||||
if fColorIndex < 0 then Exit;
|
||||
|
||||
if GetColorBrightness(Colors[fColorIndex]) >= 0.5 then
|
||||
selColor := $FF000000
|
||||
else
|
||||
selColor := $FFFFFFFF;
|
||||
|
||||
//Paint selection
|
||||
TKMRenderUI.WriteOutline(AbsLeft+(fColorIndex mod fColumnCount)*fCellSize, AbsTop+(fColorIndex div fColumnCount)*fCellSize, fCellSize, fCellSize, 1, selColor);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
@@ -0,0 +1,109 @@
|
||||
unit KM_ControlsDragger;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, Controls,
|
||||
KM_Controls;
|
||||
|
||||
|
||||
type
|
||||
//Element that player can drag within allowed bounds
|
||||
TKMDragger = class(TKMControl)
|
||||
private
|
||||
fMinusX, fMinusY, fPlusX, fPlusY: Integer; //Restrictions
|
||||
fPositionX: Integer;
|
||||
fPositionY: Integer;
|
||||
fStartDragX: Integer;
|
||||
fStartDragY: Integer;
|
||||
public
|
||||
OnMove: TKMNotifyEventXY;
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer);
|
||||
|
||||
procedure SetBounds(aMinusX, aMinusY, aPlusX, aPlusY: Integer);
|
||||
|
||||
procedure MouseDown(X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
procedure MouseMove(X,Y: Integer; Shift: TShiftState); override;
|
||||
procedure MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Math,
|
||||
KM_RenderUI,
|
||||
KM_ResTypes;
|
||||
|
||||
|
||||
{ TKMDragger }
|
||||
constructor TKMDragger.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
|
||||
//Original position is used to resrict movement
|
||||
fPositionX := 0;
|
||||
fPositionY := 0;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDragger.SetBounds(aMinusX, aMinusY, aPlusX, aPlusY: Integer);
|
||||
begin
|
||||
fMinusX := aMinusX;
|
||||
fMinusY := aMinusY;
|
||||
fPlusX := aPlusX;
|
||||
fPlusY := aPlusY;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDragger.MouseDown(X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
inherited;
|
||||
fStartDragX := X - fPositionX;
|
||||
fStartDragY := Y - fPositionY;
|
||||
|
||||
MouseMove(X,Y,Shift);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDragger.MouseMove(X,Y: Integer; Shift: TShiftState);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if csDown in State then
|
||||
begin
|
||||
//Bounds are signed numbers, set them properly
|
||||
fPositionX := EnsureRange((X - fStartDragX), fMinusX, fPlusX);
|
||||
fPositionY := EnsureRange((Y - fStartDragY), fMinusY, fPlusY);
|
||||
|
||||
if Assigned(OnMove) then OnMove(Self, fPositionX, fPositionY);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDragger.MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
inherited;
|
||||
MouseMove(X,Y,Shift);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDragger.Paint;
|
||||
var
|
||||
stateSet: TKMButtonStateSet;
|
||||
begin
|
||||
inherited;
|
||||
stateSet := [];
|
||||
if (csOver in State) and Enabled then
|
||||
stateSet := stateSet + [bsOver];
|
||||
if (csDown in State) then
|
||||
stateSet := stateSet + [bsDown];
|
||||
if not Enabled then
|
||||
stateSet := stateSet + [bsDisabled];
|
||||
|
||||
TKMRenderUI.Write3DButton(AbsLeft, AbsTop, Width, Height, rxGui, 0, $FFFF00FF, stateSet, bsGame);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
+792
@@ -0,0 +1,792 @@
|
||||
unit KM_ControlsDrop;
|
||||
interface
|
||||
uses
|
||||
Classes,
|
||||
Controls,
|
||||
KromOGLUtils,
|
||||
KM_Controls, KM_ControlsBase, KM_ControlsList,
|
||||
KM_ResTypes, KM_ResFonts,
|
||||
KM_RenderUI;
|
||||
|
||||
|
||||
type
|
||||
TKMDropCommon = class(TKMControl)
|
||||
private
|
||||
fDropCount: Integer;
|
||||
fDropUp: Boolean;
|
||||
fFont: TKMFont;
|
||||
fButton: TKMButton;
|
||||
fShape: TKMShape;
|
||||
fAutoClose: Boolean;
|
||||
|
||||
fOnChange: TNotifyEvent;
|
||||
fOnShowList: TNotifyEvent;
|
||||
|
||||
procedure UpdateDropPosition; virtual; abstract;
|
||||
procedure ButtonClick(Sender: TObject);
|
||||
procedure ListShow(Sender: TObject); virtual;
|
||||
procedure ListClick(Sender: TObject); virtual;
|
||||
procedure ListChange(Sender: TObject); virtual;
|
||||
procedure ListHide(Sender: TObject); virtual;
|
||||
function ListVisible: Boolean; virtual; abstract;
|
||||
function GetItemIndex: SmallInt; virtual; abstract;
|
||||
procedure SetItemIndex(aIndex: SmallInt); virtual; abstract;
|
||||
protected
|
||||
procedure DoClick(X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
procedure SetLeft(aValue: Integer); override;
|
||||
procedure SetTop(aValue: Integer); override;
|
||||
procedure SetEnabled(aValue: Boolean); override;
|
||||
procedure SetVisible(aValue: Boolean); override;
|
||||
function ListKeyDown(Sender: TObject; Key: Word; Shift: TShiftState): Boolean;
|
||||
procedure UpdateVisibility; override;
|
||||
function GetCount: Integer; virtual; abstract;
|
||||
procedure SetDropCount(const aValue: Integer); virtual;
|
||||
public
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aFont: TKMFont; aStyle: TKMButtonStyle;
|
||||
aAutoClose: Boolean = True);
|
||||
|
||||
procedure Clear; virtual; abstract;
|
||||
procedure OpenList;
|
||||
procedure CloseList;
|
||||
procedure SetOpenList(aOpen: Boolean);
|
||||
procedure SwitchOpen;
|
||||
|
||||
property DropCount: Integer read fDropCount write SetDropCount;
|
||||
property DropUp: Boolean read fDropUp write fDropUp;
|
||||
property ItemIndex: SmallInt read GetItemIndex write SetItemIndex;
|
||||
function IsOpen: Boolean; virtual;
|
||||
property Count: Integer read GetCount;
|
||||
|
||||
property OnShowList: TNotifyEvent read fOnShowList write fOnShowList;
|
||||
property OnChange: TNotifyEvent read fOnChange write fOnChange;
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
//DropBox with a ListBox
|
||||
TKMDropList = class(TKMDropCommon)
|
||||
private
|
||||
fCaption: UnicodeString; //Current caption (Default or from list)
|
||||
fDefaultCaption: UnicodeString;
|
||||
fDropWidth: Integer;
|
||||
fList: TKMListBox;
|
||||
fListTopIndex: Integer;
|
||||
procedure UpdateDropPosition; override;
|
||||
procedure ListShow(Sender: TObject); override;
|
||||
procedure ListClick(Sender: TObject); override;
|
||||
procedure ListChange(Sender: TObject); override;
|
||||
procedure ListHide(Sender: TObject); override;
|
||||
function ListVisible: Boolean; override;
|
||||
function GetItem(aIndex: Integer): UnicodeString;
|
||||
function GetItemIndex: smallint; override;
|
||||
procedure SetItemIndex(aIndex: smallint); override;
|
||||
procedure SetDropWidth(aDropWidth: Integer);
|
||||
function GetShowHintWhenShort: Boolean;
|
||||
procedure SetShowHintWhenShort(const aValue: Boolean);
|
||||
protected
|
||||
procedure SetEnabled(aValue: Boolean); override;
|
||||
procedure SetVisible(aValue: Boolean); override;
|
||||
function GetCount: Integer; override;
|
||||
procedure SetDropCount(const aValue: Integer); override;
|
||||
public
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aFont: TKMFont; const aDefaultCaption: UnicodeString;
|
||||
aStyle: TKMButtonStyle; aAutoClose: Boolean = True; aBackAlpha: Single = 0.85);
|
||||
procedure Clear; override;
|
||||
procedure Add(const aItem: UnicodeString; aTag: Integer = 0);
|
||||
procedure SelectByName(const aText: UnicodeString);
|
||||
procedure SelectByTag(aTag: Integer);
|
||||
function HasTag(aTag: Integer): Boolean;
|
||||
function GetTag(aIndex: Integer): Integer;
|
||||
function GetSelectedTag: Integer;
|
||||
function IsSelected: Boolean;
|
||||
property ShowHintWhenShort: Boolean read GetShowHintWhenShort write SetShowHintWhenShort;
|
||||
property DefaultCaption: UnicodeString read fDefaultCaption write fDefaultCaption;
|
||||
property Item[aIndex: Integer]: UnicodeString read GetItem;
|
||||
property List: TKMListBox read fList;
|
||||
function IsOpen: Boolean; override;
|
||||
property DropWidth: Integer read fDropWidth write SetDropWidth;
|
||||
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
//DropBox with a ColumnBox
|
||||
TKMDropColumns = class(TKMDropCommon)
|
||||
private
|
||||
fDefaultCaption: UnicodeString;
|
||||
fDropWidth: Integer;
|
||||
fList: TKMColumnBox;
|
||||
fListTopIndex: Integer;
|
||||
fColumnsToShowWhenListHidden: array of Boolean; //which columns to show, when list is hidden
|
||||
procedure UpdateDropPosition; override;
|
||||
procedure ListShow(Sender: TObject); override;
|
||||
procedure ListClick(Sender: TObject); override;
|
||||
procedure ListChange(Sender: TObject); override;
|
||||
procedure ListHide(Sender: TObject); override;
|
||||
function ListVisible: Boolean; override;
|
||||
function GetItem(aIndex: Integer): TKMListRow;
|
||||
function GetItemIndex: Smallint; override;
|
||||
procedure SetItemIndex(aIndex: Smallint); override;
|
||||
procedure SetDropWidth(aDropWidth: Integer);
|
||||
function GetShowHintWhenShort: Boolean;
|
||||
procedure SetShowHintWhenShort(const aValue: Boolean);
|
||||
protected
|
||||
procedure SetEnabled(aValue: Boolean); override;
|
||||
procedure SetVisible(aValue: Boolean); override;
|
||||
function GetCount: Integer; override;
|
||||
public
|
||||
FadeImageWhenDisabled: Boolean;
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aFont: TKMFont; const aDefaultCaption: UnicodeString; aStyle: TKMButtonStyle; aShowHeader: Boolean = True);
|
||||
procedure Add(aItem: TKMListRow);
|
||||
procedure Clear; override;
|
||||
property List: TKMColumnBox read fList;
|
||||
property Item[aIndex: Integer]: TKMListRow read GetItem; default;
|
||||
procedure SetColumns(aFont: TKMFont; aColumns: array of string; aColumnOffsets: array of Word); overload;
|
||||
procedure SetColumns(aFont: TKMFont; aColumns: array of string; aColumnOffsets: array of Word; aColumnsToShowWhenListHidden: array of Boolean); overload;
|
||||
property DefaultCaption: UnicodeString read fDefaultCaption write fDefaultCaption;
|
||||
property DropWidth: Integer read fDropWidth write SetDropWidth;
|
||||
property ShowHintWhenShort: Boolean read GetShowHintWhenShort write SetShowHintWhenShort;
|
||||
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
{$IFDEF MSWindows} Windows, {$ENDIF}
|
||||
{$IFDEF Unix} LCLIntf, LCLType, {$ENDIF}
|
||||
Math,
|
||||
KM_Defaults;
|
||||
|
||||
|
||||
{ TKMDropCommon }
|
||||
constructor TKMDropCommon.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aFont: TKMFont;
|
||||
aStyle: TKMButtonStyle; aAutoClose: Boolean = True);
|
||||
var
|
||||
P: TKMPanel;
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
|
||||
fDropCount := 10;
|
||||
fDropUp := False;
|
||||
fFont := aFont;
|
||||
|
||||
fButton := TKMButton.Create(aParent, aLeft+aWidth-aHeight, aTop, aHeight, aHeight, 590, rxGui, aStyle);
|
||||
fButton.OnClick := ButtonClick;
|
||||
fButton.MakesSound := False;
|
||||
|
||||
P := MasterParent;
|
||||
fShape := TKMShape.Create(P, 0, 0, P.Width, P.Height);
|
||||
fShape.AnchorsStretch;
|
||||
fShape.OnClick := ListHide;
|
||||
|
||||
fAutoClose := aAutoClose;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.UpdateVisibility;
|
||||
begin
|
||||
inherited;
|
||||
if not Visible then
|
||||
CloseList;
|
||||
end;
|
||||
|
||||
|
||||
function TKMDropCommon.IsOpen: Boolean;
|
||||
begin
|
||||
Result := fShape.Visible;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.ButtonClick(Sender: TObject);
|
||||
begin
|
||||
//Call the DoDlick event to show the list AND generate DropBox.OnClick event
|
||||
DoClick(fButton.AbsLeft + fButton.Width div 2, fButton.AbsTop + fButton.Height div 2, [], mbLeft);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.ListShow(Sender: TObject);
|
||||
begin
|
||||
if ListVisible then
|
||||
begin
|
||||
ListHide(nil);
|
||||
Exit;
|
||||
end;
|
||||
|
||||
if fAutoClose and (Count > 0) then
|
||||
fShape.Show;
|
||||
|
||||
if Assigned(fOnShowList) then fOnShowList(Self);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.DoClick(X, Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
//do not invoke inherited here, to fully override parent DoClick method
|
||||
|
||||
//It's common behavior when click on dropbox will show the list
|
||||
if fAutoClose then
|
||||
ListShow(Self)
|
||||
else
|
||||
if not ListVisible then
|
||||
begin
|
||||
fButton.TexId := 591;
|
||||
ListShow(Self)
|
||||
end else begin
|
||||
fButton.TexId := 590;
|
||||
ListHide(Self);
|
||||
end;
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
//Handle KeyDown on List
|
||||
function TKMDropCommon.ListKeyDown(Sender: TObject; Key: Word; Shift: TShiftState): Boolean;
|
||||
begin
|
||||
if fAutoClose and (Key = VK_ESCAPE) then // Close List on ESC, if autoclosable
|
||||
begin
|
||||
ListHide(nil);
|
||||
Result := True;
|
||||
end else
|
||||
Result := False;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.ListClick(Sender: TObject);
|
||||
begin
|
||||
//No need to call fOnChange here since ListChange was already called
|
||||
if fAutoClose then ListHide(nil);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.ListChange(Sender: TObject);
|
||||
begin
|
||||
if (ItemIndex <> -1) then
|
||||
if Assigned(fOnChange) then fOnChange(Self);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.ListHide(Sender: TObject);
|
||||
begin
|
||||
fShape.Hide;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.SetDropCount(const aValue: Integer);
|
||||
begin
|
||||
fDropCount := aValue;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.SetEnabled(aValue: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
fButton.Enabled := Enabled;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.OpenList;
|
||||
begin
|
||||
ListShow(nil);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.CloseList;
|
||||
begin
|
||||
ListHide(nil);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.SetOpenList(aOpen: Boolean);
|
||||
begin
|
||||
if aOpen then
|
||||
OpenList
|
||||
else
|
||||
CloseList;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.SwitchOpen;
|
||||
begin
|
||||
if IsOpen then
|
||||
CloseList
|
||||
else
|
||||
OpenList;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.SetLeft(aValue: Integer);
|
||||
begin
|
||||
inherited;
|
||||
// Stick the button to us
|
||||
fButton.Left := Left + Width - Height;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.SetTop(aValue: Integer);
|
||||
begin
|
||||
inherited;
|
||||
// Stick the button to us
|
||||
fButton.Top := Top;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.SetVisible(aValue: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
fButton.Visible := aValue;
|
||||
if not aValue then ListHide(Self);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropCommon.Paint;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
TKMRenderUI.WriteBevel(AbsLeft, AbsTop, Width, Height);
|
||||
|
||||
// Make sure the list stays where it needs to be relative DropBox (e.g. on window resize)
|
||||
UpdateDropPosition;
|
||||
end;
|
||||
|
||||
|
||||
{ TKMDropList }
|
||||
constructor TKMDropList.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aFont: TKMFont; const aDefaultCaption: UnicodeString;
|
||||
aStyle: TKMButtonStyle; aAutoClose: Boolean = True; aBackAlpha: Single = 0.85);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight, aFont, aStyle, aAutoClose);
|
||||
|
||||
fDefaultCaption := aDefaultCaption;
|
||||
|
||||
fListTopIndex := 0;
|
||||
|
||||
fList := TKMListBox.Create(MasterParent, 0, 0, aWidth, 0, fFont, aStyle);
|
||||
fList.Height := fList.ItemHeight * fDropCount;
|
||||
fList.AutoHideScrollBar := True; //A drop box should only have a scrollbar if required
|
||||
fList.BackAlpha := aBackAlpha;
|
||||
fList.OnClick := ListClick;
|
||||
fList.OnChange := ListChange;
|
||||
|
||||
DropWidth := aWidth;
|
||||
|
||||
ListHide(nil);
|
||||
fList.OnKeyDown := ListKeyDown;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropList.ListShow(Sender: TObject);
|
||||
begin
|
||||
inherited;
|
||||
if ListVisible or (Count < 1) then Exit;
|
||||
|
||||
//Make sure the selected item is visible when list is opened
|
||||
if (ItemIndex <> -1) then
|
||||
begin
|
||||
if InRange(ItemIndex, fListTopIndex, fListTopIndex + fList.GetVisibleRows) then //Try to open list at previously saved scroll position
|
||||
fList.TopIndex := fListTopIndex
|
||||
else
|
||||
fList.TopIndex := ItemIndex;
|
||||
end;
|
||||
|
||||
fList.Show;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropList.ListClick(Sender: TObject);
|
||||
begin
|
||||
fCaption := fList.Item[ItemIndex];
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropList.ListChange(Sender: TObject);
|
||||
begin
|
||||
fCaption := fList.Item[ItemIndex];
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropList.ListHide(Sender: TObject);
|
||||
begin
|
||||
fListTopIndex := fList.TopIndex; //Save list scroll position
|
||||
inherited;
|
||||
fList.Hide;
|
||||
end;
|
||||
|
||||
|
||||
function TKMDropList.ListVisible: Boolean;
|
||||
begin
|
||||
Result := fList.Visible;
|
||||
end;
|
||||
|
||||
|
||||
function TKMDropList.GetItemIndex: Smallint;
|
||||
begin
|
||||
Result := fList.ItemIndex;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropList.SetItemIndex(aIndex: Smallint);
|
||||
begin
|
||||
fList.ItemIndex := aIndex;
|
||||
if aIndex <> -1 then
|
||||
fCaption := fList.Item[fList.ItemIndex]
|
||||
else
|
||||
fCaption := fDefaultCaption;
|
||||
end;
|
||||
|
||||
|
||||
function TKMDropList.GetShowHintWhenShort: Boolean;
|
||||
begin
|
||||
Result := fList.ShowHintWhenShort;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropList.SetShowHintWhenShort(const aValue: Boolean);
|
||||
begin
|
||||
fList.ShowHintWhenShort := aValue;
|
||||
end;
|
||||
|
||||
|
||||
function TKMDropList.IsOpen: Boolean;
|
||||
begin
|
||||
Result := fList.Visible;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropList.SetDropCount(const aValue: Integer);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
fList.Height := fList.ItemHeight * fDropCount;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropList.SetDropWidth(aDropWidth: Integer);
|
||||
begin
|
||||
fDropWidth := aDropWidth;
|
||||
fList.AbsLeft := AbsLeft + Width - aDropWidth;
|
||||
fList.Width := aDropWidth;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropList.SetEnabled(aValue: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
fList.Enabled := Enabled;
|
||||
if not Enabled and fList.Visible then
|
||||
ListHide(nil);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropList.SetVisible(aValue: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
if not aValue then ListHide(Self);
|
||||
end;
|
||||
|
||||
|
||||
function TKMDropList.GetCount: Integer;
|
||||
begin
|
||||
Result := fList.Count;
|
||||
end;
|
||||
|
||||
|
||||
// When new items are added to the list we must update the drop height and position
|
||||
procedure TKMDropList.UpdateDropPosition;
|
||||
begin
|
||||
if Count > 0 then
|
||||
begin
|
||||
fList.Height := Math.Min(fDropCount, fList.Count) * fList.ItemHeight + fList.SeparatorsCount*fList.SeparatorHeight;
|
||||
|
||||
if fDropUp then
|
||||
fList.AbsTop := AbsTop - fList.Height
|
||||
else
|
||||
fList.AbsTop := AbsTop + Height;
|
||||
|
||||
fList.Left := AbsLeft + Width - DropWidth - MasterParent.AbsLeft;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropList.Add(const aItem: UnicodeString; aTag: Integer = 0);
|
||||
begin
|
||||
fList.Add(aItem, aTag);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropList.SelectByName(const aText: UnicodeString);
|
||||
var I: Integer;
|
||||
begin
|
||||
fList.ItemIndex := -1;
|
||||
for I := 0 to fList.Count - 1 do
|
||||
if fList.Item[I] = aText then
|
||||
SetItemIndex(I);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropList.SelectByTag(aTag: Integer);
|
||||
var I: Integer;
|
||||
begin
|
||||
fList.ItemIndex := -1;
|
||||
for I := 0 to fList.Count - 1 do
|
||||
if fList.ItemTags[I] = aTag then
|
||||
SetItemIndex(I);
|
||||
end;
|
||||
|
||||
|
||||
function TKMDropList.HasTag(aTag: Integer): Boolean;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
for I := 0 to fList.Count - 1 do
|
||||
if fList.ItemTags[I] = aTag then
|
||||
Exit(True);
|
||||
end;
|
||||
|
||||
|
||||
function TKMDropList.IsSelected: Boolean;
|
||||
begin
|
||||
Result := fList.ItemIndex <> -1;
|
||||
end;
|
||||
|
||||
|
||||
function TKMDropList.GetTag(aIndex: Integer): Integer;
|
||||
begin
|
||||
Result := fList.ItemTags[aIndex];
|
||||
end;
|
||||
|
||||
|
||||
function TKMDropList.GetSelectedTag: Integer;
|
||||
begin
|
||||
Result := GetTag(fList.ItemIndex);
|
||||
end;
|
||||
|
||||
function TKMDropList.GetItem(aIndex: Integer): UnicodeString;
|
||||
begin
|
||||
Result := fList.Item[aIndex];
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropList.Clear;
|
||||
begin
|
||||
fList.Clear;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropList.Paint;
|
||||
var
|
||||
col: TColor4;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if Enabled then
|
||||
col := icWhite
|
||||
else
|
||||
col := icGray2;
|
||||
|
||||
TKMRenderUI.WriteText(AbsLeft+4, AbsTop+4, Width-8, fCaption, fFont, taLeft, col);
|
||||
end;
|
||||
|
||||
|
||||
{ TKMDropColumns }
|
||||
constructor TKMDropColumns.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aFont: TKMFont; const aDefaultCaption: UnicodeString; aStyle: TKMButtonStyle; aShowHeader: Boolean = True);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight, aFont, aStyle);
|
||||
|
||||
fListTopIndex := 0;
|
||||
|
||||
fDefaultCaption := aDefaultCaption;
|
||||
|
||||
fList := TKMColumnBox.Create(MasterParent, 0, 0, aWidth, 0, fFont, aStyle);
|
||||
fList.BackAlpha := 0.85;
|
||||
fList.OnClick := ListClick;
|
||||
fList.OnChange := ListChange;
|
||||
fList.ShowHeader := aShowHeader;
|
||||
|
||||
DropWidth := aWidth;
|
||||
|
||||
ListHide(nil);
|
||||
fList.OnKeyDown := ListKeyDown;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropColumns.ListShow(Sender: TObject);
|
||||
begin
|
||||
inherited;
|
||||
if ListVisible or (Count < 1) then Exit;
|
||||
|
||||
//Make sure the selected item is visible when list is opened
|
||||
if (ItemIndex <> -1) then
|
||||
begin
|
||||
if InRange(ItemIndex, fListTopIndex, fListTopIndex + fList.GetVisibleRows) then //Try to open list at previously saved scroll position
|
||||
fList.TopIndex := fListTopIndex
|
||||
else
|
||||
fList.TopIndex := ItemIndex;
|
||||
end;
|
||||
|
||||
fList.Show;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropColumns.ListClick(Sender: TObject);
|
||||
begin
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropColumns.ListChange(Sender: TObject);
|
||||
begin
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropColumns.ListHide(Sender: TObject);
|
||||
begin
|
||||
fListTopIndex := fList.TopIndex; //Save list scroll position
|
||||
inherited;
|
||||
fList.Hide;
|
||||
end;
|
||||
|
||||
|
||||
function TKMDropColumns.ListVisible: Boolean;
|
||||
begin
|
||||
Result := fList.Visible;
|
||||
end;
|
||||
|
||||
|
||||
function TKMDropColumns.GetItemIndex: smallint;
|
||||
begin
|
||||
Result := fList.ItemIndex;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropColumns.SetItemIndex(aIndex: smallint);
|
||||
begin
|
||||
fList.ItemIndex := aIndex;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropColumns.SetDropWidth(aDropWidth: Integer);
|
||||
begin
|
||||
fDropWidth := aDropWidth;
|
||||
fList.AbsLeft := AbsLeft + Width - aDropWidth;
|
||||
fList.Width := aDropWidth;
|
||||
end;
|
||||
|
||||
|
||||
function TKMDropColumns.GetShowHintWhenShort: Boolean;
|
||||
begin
|
||||
Result := fList.ShowHintWhenShort
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropColumns.SetShowHintWhenShort(const aValue: Boolean);
|
||||
begin
|
||||
fList.ShowHintWhenShort := aValue;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropColumns.SetColumns(aFont: TKMFont; aColumns: array of string; aColumnOffsets: array of Word);
|
||||
var
|
||||
I: Integer;
|
||||
columnsToShowWhenListHidden: array of Boolean;
|
||||
begin
|
||||
SetLength(columnsToShowWhenListHidden, Length(aColumns));
|
||||
for I := Low(columnsToShowWhenListHidden) to High(columnsToShowWhenListHidden) do
|
||||
columnsToShowWhenListHidden[I] := True; // by default show all columns
|
||||
SetColumns(aFont, aColumns, aColumnOffsets, columnsToShowWhenListHidden);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropColumns.SetColumns(aFont: TKMFont; aColumns: array of string; aColumnOffsets: array of Word; aColumnsToShowWhenListHidden: array of Boolean);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
Assert(Length(aColumns) = Length(aColumnsToShowWhenListHidden));
|
||||
fList.SetColumns(aFont, aColumns, aColumnOffsets);
|
||||
SetLength(fColumnsToShowWhenListHidden, Length(aColumnsToShowWhenListHidden));
|
||||
for I := Low(aColumnsToShowWhenListHidden) to High(aColumnsToShowWhenListHidden) do
|
||||
fColumnsToShowWhenListHidden[I] := aColumnsToShowWhenListHidden[I];
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropColumns.SetEnabled(aValue: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
fList.Enabled := Enabled;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropColumns.SetVisible(aValue: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
if not aValue then ListHide(Self);
|
||||
end;
|
||||
|
||||
|
||||
function TKMDropColumns.GetCount: Integer;
|
||||
begin
|
||||
Result := fList.RowCount;
|
||||
end;
|
||||
|
||||
|
||||
//When new items are added to the list we must update the drop height and position
|
||||
procedure TKMDropColumns.UpdateDropPosition;
|
||||
begin
|
||||
if Count > 0 then
|
||||
begin
|
||||
fList.Height := Math.Min(fDropCount, fList.RowCount) * fList.ItemHeight + fList.Header.Height * Ord(fList.ShowHeader);
|
||||
|
||||
if fDropUp then
|
||||
fList.AbsTop := AbsTop - fList.Height
|
||||
else
|
||||
fList.AbsTop := AbsTop + Height;
|
||||
|
||||
fList.Left := AbsLeft + Width - DropWidth - MasterParent.AbsLeft;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropColumns.Add(aItem: TKMListRow);
|
||||
begin
|
||||
fList.AddItem(aItem);
|
||||
end;
|
||||
|
||||
|
||||
function TKMDropColumns.GetItem(aIndex: Integer): TKMListRow;
|
||||
begin
|
||||
Result := fList.Rows[aIndex];
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropColumns.Clear;
|
||||
begin
|
||||
fList.Clear;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMDropColumns.Paint;
|
||||
var
|
||||
col: TColor4;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if Enabled then
|
||||
col := icWhite
|
||||
else
|
||||
col := icGray2;
|
||||
|
||||
if ItemIndex = -1 then
|
||||
TKMRenderUI.WriteText(AbsLeft + 4, AbsTop + 4, Width - 8 - fButton.Width, fDefaultCaption, fFont, taLeft, col)
|
||||
else
|
||||
fList.DoPaintLine(ItemIndex, AbsLeft, AbsTop, Width - fButton.Width, fColumnsToShowWhenListHidden, False);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
+1050
File diff suppressed because it is too large.
Load diff
+350
@@ -0,0 +1,350 @@
|
||||
unit KM_ControlsForm;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, Controls,
|
||||
KM_Controls, KM_ControlsBase,
|
||||
KM_CommonTypes, KM_Points, KM_ResFonts;
|
||||
|
||||
|
||||
type
|
||||
TKMFormBackgroundType = (
|
||||
fbGray, // Dark grey scroll with big header roll
|
||||
fbYellow, // Yellow scroll without header roll
|
||||
fbScroll // Yellow scroll with small header roll
|
||||
);
|
||||
|
||||
TKMForm = class(TKMPanel)
|
||||
const
|
||||
DEFAULT_CAPTION_FONT = fntOutline;
|
||||
private
|
||||
fDragging: Boolean;
|
||||
fDragStartPos: TKMPoint;
|
||||
fBackground: TKMFormBackgroundType;
|
||||
fHandleCloseKey: Boolean;
|
||||
fCapOffsetY: Integer;
|
||||
|
||||
fOnClose: TKMEvent;
|
||||
procedure UpdateSizes;
|
||||
procedure Close(Sender: TObject);
|
||||
|
||||
procedure HandleOtherControlMouseMove(Sender: TObject; X,Y: Integer; Shift: TShiftState);
|
||||
procedure HandleOtherControlMouseDown(Sender: TObject; X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
procedure HandleOtherControlMouseUp(Sender: TObject; X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
|
||||
function MarginMainLeftRight: Integer;
|
||||
function MarginMainTop: Integer;
|
||||
function MarginMainBottom: Integer;
|
||||
function MarginCrossTop: Integer;
|
||||
function MarginCrossRight: Integer;
|
||||
|
||||
function GetActualWidth: Integer;
|
||||
procedure SetActualWidth(aValue: Integer);
|
||||
function GetActualHeight: Integer;
|
||||
procedure SetActualHeight(aValue: Integer);
|
||||
|
||||
procedure SetHandleCloseKey(aValue: Boolean);
|
||||
procedure SetCapOffsetY(aValue: Integer);
|
||||
function GetCaption: string;
|
||||
procedure SetCaption(const aValue: string);
|
||||
protected
|
||||
Bevel_Contents: TKMBevel;
|
||||
Bevel_ModalBackground: TKMBevel;
|
||||
Image_Background, Image_Close: TKMImage;
|
||||
Label_Caption: TKMLabel;
|
||||
procedure SetWidth(aValue: Integer); override;
|
||||
procedure SetHeight(aValue: Integer); override;
|
||||
public
|
||||
ItemsPanel: TKMPanel;
|
||||
DragEnabled: Boolean;
|
||||
|
||||
constructor Create(aParent: TKMPanel; aContentWidth, aContentHeight: Integer; const aCaption: UnicodeString = '';
|
||||
aBackground: TKMFormBackgroundType = fbYellow; aCloseIcon: Boolean = False;
|
||||
aBevelForContents: Boolean = True; aModalBackground: Boolean = True);
|
||||
|
||||
procedure MouseDown (X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
procedure MouseMove (X,Y: Integer; Shift: TShiftState); override;
|
||||
procedure MouseUp (X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
|
||||
function KeyUp(Key: Word; Shift: TShiftState): Boolean; override;
|
||||
|
||||
property OnClose: TKMEvent read fOnClose write fOnClose;
|
||||
|
||||
property ActualHeight: Integer read GetActualHeight write SetActualHeight;
|
||||
property ActualWidth: Integer read GetActualWidth write SetActualWidth;
|
||||
property CapOffsetY: Integer read fCapOffsetY write SetCapOffsetY;
|
||||
property Caption: string read GetCaption write SetCaption;
|
||||
|
||||
property HandleCloseKey: Boolean read fHandleCloseKey write SetHandleCloseKey;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Math,
|
||||
KM_RenderUI,
|
||||
KM_ResTexts, KM_ResKeys, KM_ResTypes;
|
||||
|
||||
|
||||
{ TKMForm }
|
||||
constructor TKMForm.Create(aParent: TKMPanel; aContentWidth, aContentHeight: Integer; const aCaption: UnicodeString = '';
|
||||
aBackground: TKMFormBackgroundType = fbYellow; aCloseIcon: Boolean = False;
|
||||
aBevelForContents: Boolean = True; aModalBackground: Boolean = True);
|
||||
const
|
||||
BG_RX: array [TKMFormBackgroundType] of TRXType = (rxGuiMain, rxGuiMain, rxGui);
|
||||
BG_ID: array [TKMFormBackgroundType] of Word = (15, 18, 409);
|
||||
begin
|
||||
fBackground := aBackground;
|
||||
|
||||
var desiredWidth := aContentWidth + 2 * MarginMainLeftRight;
|
||||
var desiredHeight := aContentHeight + MarginMainBottom + MarginMainTop;
|
||||
var desiredLeft := Max(0, (aParent.Width - desiredWidth) div 2);
|
||||
var desiredTop := Max(0, (aParent.Height - desiredHeight) div 2);
|
||||
|
||||
// Create panel with calculated sizes
|
||||
inherited Create(aParent, desiredLeft, desiredTop, desiredWidth, desiredHeight);
|
||||
|
||||
// Fix its base sizes as a desired one
|
||||
BaseWidth := desiredWidth;
|
||||
BaseHeight := desiredHeight;
|
||||
|
||||
// FitInParent := True; not sure if this is ever needed
|
||||
DragEnabled := False;
|
||||
fHandleCloseKey := False;
|
||||
fCapOffsetY := 0;
|
||||
|
||||
if aModalBackground then
|
||||
Bevel_ModalBackground := TKMBevel.Create(Self, -5000, -5000, 10000, 10000);
|
||||
|
||||
Image_Background := TKMImage.Create(Self, 0, 0, desiredWidth, desiredHeight, BG_ID[fBackground], BG_RX[fBackground]);
|
||||
Image_Background.AnchorsStretch;
|
||||
Image_Background.ImageStretch;
|
||||
|
||||
if aCloseIcon then
|
||||
begin
|
||||
Image_Close := TKMImage.Create(Self, Width - MarginCrossRight, MarginCrossTop, 31, 30, 52);
|
||||
Image_Close.Anchors := [anTop, anRight];
|
||||
Image_Close.Hint := gResTexts[TX_MSG_CLOSE_HINT];
|
||||
Image_Close.OnClick := Close;
|
||||
Image_Close.HighlightOnMouseOver := True;
|
||||
end;
|
||||
|
||||
ItemsPanel := TKMPanel.Create(Self, MarginMainLeftRight, MarginMainTop, Width - 2*MarginMainLeftRight, Height - MarginMainTop - MarginMainBottom);
|
||||
ItemsPanel.AnchorsStretch;
|
||||
if aBevelForContents then
|
||||
begin
|
||||
Bevel_Contents := TKMBevel.Create(ItemsPanel, 0, 0, ItemsPanel.Width, ItemsPanel.Height);
|
||||
Bevel_Contents.AnchorsStretch;
|
||||
end;
|
||||
|
||||
Label_Caption := TKMLabel.Create(ItemsPanel, 0, -25, ItemsPanel.Width, 20, aCaption, DEFAULT_CAPTION_FONT, taCenter);
|
||||
|
||||
AnchorsCenter;
|
||||
Hide;
|
||||
|
||||
fMasterControl.SubscribeOnOtherMouseMove(HandleOtherControlMouseMove);
|
||||
fMasterControl.SubscribeOnOtherMouseDown(HandleOtherControlMouseDown);
|
||||
fMasterControl.SubscribeOnOtherMouseUp(HandleOtherControlMouseUp);
|
||||
end;
|
||||
|
||||
|
||||
function TKMForm.MarginMainLeftRight: Integer;
|
||||
const
|
||||
MARGIN_SIDE: array [TKMFormBackgroundType] of Byte = (20, 35, 20);
|
||||
begin
|
||||
Result := MARGIN_SIDE[fBackground];
|
||||
end;
|
||||
|
||||
|
||||
function TKMForm.MarginMainTop: Integer;
|
||||
const
|
||||
MARGIN_TOP: array [TKMFormBackgroundType] of Byte = (40, 80, 50);
|
||||
begin
|
||||
Result := MARGIN_TOP[fBackground];
|
||||
end;
|
||||
|
||||
|
||||
function TKMForm.MarginMainBottom: Integer;
|
||||
const
|
||||
MARGIN_BOTTOM: array [TKMFormBackgroundType] of Byte = (20, 50, 20);
|
||||
begin
|
||||
Result := MARGIN_BOTTOM[fBackground];
|
||||
end;
|
||||
|
||||
|
||||
function TKMForm.MarginCrossTop: Integer;
|
||||
const
|
||||
CROSS_TOP: array [TKMFormBackgroundType] of Byte = (24, 40, 24);
|
||||
begin
|
||||
Result := CROSS_TOP[fBackground];
|
||||
end;
|
||||
|
||||
|
||||
function TKMForm.MarginCrossRight: Integer;
|
||||
const
|
||||
// Margin from right side, depends on bg graphics
|
||||
CROSS_RIGHT: array [TKMFormBackgroundType] of Byte = (50, 130, 55);
|
||||
begin
|
||||
Result := CROSS_RIGHT[fBackground];
|
||||
end;
|
||||
|
||||
|
||||
function TKMForm.GetCaption: string;
|
||||
begin
|
||||
Result := Label_Caption.Caption;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMForm.Close(Sender: TObject);
|
||||
begin
|
||||
Hide;
|
||||
|
||||
if Assigned(fOnClose) then
|
||||
fOnClose;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMForm.HandleOtherControlMouseDown(Sender: TObject; X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
if Sender = Image_Background then
|
||||
MouseDown(X, Y, Shift, Button);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMForm.HandleOtherControlMouseMove(Sender: TObject; X, Y: Integer; Shift: TShiftState);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
MouseMove(X, Y, Shift);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMForm.HandleOtherControlMouseUp(Sender: TObject; X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
MouseUp(X, Y, Shift, Button);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMForm.MouseDown(X, Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if not DragEnabled then Exit;
|
||||
|
||||
fDragging := True;
|
||||
fDragStartPos := TKMPoint.New(X,Y);
|
||||
end;
|
||||
|
||||
procedure TKMForm.MouseMove(X, Y: Integer; Shift: TShiftState);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if not DragEnabled or not fDragging then Exit;
|
||||
|
||||
Left := EnsureRange(Left + X - fDragStartPos.X, 0, fMasterControl.MasterPanel.Width - Width);
|
||||
Top := EnsureRange(Top + Y - fDragStartPos.Y, -Image_Background.Top, fMasterControl.MasterPanel.Height - Height);
|
||||
|
||||
fDragStartPos := TKMPoint.New(X,Y);
|
||||
end;
|
||||
|
||||
procedure TKMForm.MouseUp(X, Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if not DragEnabled then Exit;
|
||||
|
||||
fDragging := False;
|
||||
end;
|
||||
|
||||
|
||||
function TKMForm.KeyUp(Key: Word; Shift: TShiftState): Boolean;
|
||||
begin
|
||||
Result := inherited;
|
||||
if Result then Exit; // Key already handled
|
||||
|
||||
if not fHandleCloseKey then Exit;
|
||||
|
||||
if Key = gResKeys[kfCloseMenu] then
|
||||
begin
|
||||
Close(nil);
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMForm.SetHeight(aValue: Integer);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
UpdateSizes;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMForm.SetWidth(aValue: Integer);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
UpdateSizes;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMForm.UpdateSizes;
|
||||
begin
|
||||
// Reposition buttons?
|
||||
end;
|
||||
|
||||
|
||||
function TKMForm.GetActualWidth: Integer;
|
||||
begin
|
||||
Result := ItemsPanel.Width;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMForm.SetActualWidth(aValue: Integer);
|
||||
var
|
||||
baseW: Integer;
|
||||
begin
|
||||
baseW := aValue + MarginMainLeftRight*2;
|
||||
SetWidth(Min(Parent.Width, baseW));
|
||||
end;
|
||||
|
||||
|
||||
function TKMForm.GetActualHeight: Integer;
|
||||
begin
|
||||
Result := ItemsPanel.Height;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMForm.SetActualHeight(aValue: Integer);
|
||||
var
|
||||
baseH, h: Integer;
|
||||
begin
|
||||
baseH := aValue + MarginMainBottom + MarginMainTop;
|
||||
h := Min(Parent.Height, baseH);
|
||||
SetHeight(h);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMForm.SetHandleCloseKey(aValue: Boolean);
|
||||
begin
|
||||
fHandleCloseKey := aValue;
|
||||
Focusable := aValue;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMForm.SetCapOffsetY(aValue: Integer);
|
||||
begin
|
||||
Label_Caption.Top := Label_Caption.Top + aValue - fCapOffsetY;
|
||||
|
||||
fCapOffsetY := aValue;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMForm.SetCaption(const aValue: string);
|
||||
begin
|
||||
Label_Caption.Caption := aValue;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
+2093
File diff suppressed because it is too large.
Load diff
+783
@@ -0,0 +1,783 @@
|
||||
unit KM_ControlsMemo;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, Controls,
|
||||
KM_Controls, KM_ControlsScroll,
|
||||
KM_RenderUI, KM_ResFonts,
|
||||
KM_CommonTypes, KM_Points;
|
||||
|
||||
|
||||
type
|
||||
TKMMemo = class(TKMControl)
|
||||
private
|
||||
fFont: TKMFont; //Should not be changed from inital value, it will mess up the word wrapping
|
||||
fItemHeight: Byte;
|
||||
fItems: TStringList;
|
||||
fWordWrap: Boolean;
|
||||
fIndentAfterNL: Boolean;
|
||||
fText: UnicodeString;
|
||||
fScrollDown: Boolean;
|
||||
fScrollBar: TKMScrollBar;
|
||||
fOnChange: TNotifyEvent;
|
||||
fCursorPos: Integer;
|
||||
fSelectable: Boolean;
|
||||
fSelectionStart: Integer;
|
||||
fSelectionEnd: Integer;
|
||||
fSelectionInitialPos: Integer;
|
||||
|
||||
procedure SetWordWrap(const Value: Boolean);
|
||||
function GetText: UnicodeString;
|
||||
procedure SetText(const aText: UnicodeString);
|
||||
function GetTopIndex: smallint;
|
||||
procedure SetTopIndex(aIndex: SmallInt);
|
||||
procedure ReformatText;
|
||||
procedure UpdateScrollBar;
|
||||
|
||||
function KeyEventHandled(Key: Word; Shift: TShiftState): Boolean;
|
||||
|
||||
procedure SetCursorPos(aPos: Integer);
|
||||
function LinearToPointPos(aPos: Integer): TKMPoint;
|
||||
function PointToLinearPos(aColumn, aRow: Integer): Integer;
|
||||
function GetCharPosAt(X,Y: Integer): TKMPoint;
|
||||
function GetCursorPosAt(X,Y: Integer): Integer;
|
||||
procedure ResetSelection;
|
||||
function HasSelection: Boolean;
|
||||
function GetPlainText(aUsePipeAsEOL: Boolean; aStart: Integer = -1; aEnd: Integer = -1): UnicodeString;
|
||||
function GetSelectedText: UnicodeString;
|
||||
function GetMaxCursorPos: Integer;
|
||||
function GetMaxPosInRow(aRow: Integer): Integer;
|
||||
function GetMinPosInRow(aRow: Integer): Integer;
|
||||
function GetMaxCursorPosInRow: Integer;
|
||||
function GetMinCursorPosInRow: Integer;
|
||||
procedure SetSelectionStart(aValue: Integer);
|
||||
procedure SetSelectionEnd(aValue: Integer);
|
||||
procedure SetSelections(aValue1, aValue2: Integer);
|
||||
procedure UpdateSelection(aOldCursorPos: Integer; aIsSelecting: Boolean);
|
||||
protected
|
||||
procedure SetHeight(aValue: Integer); override;
|
||||
procedure SetWidth(aValue: Integer); override;
|
||||
procedure SetVisible(aValue: Boolean); override;
|
||||
procedure SetEnabled(aValue: Boolean); override;
|
||||
procedure SetTop(aValue: Integer); override;
|
||||
procedure FocusChanged(aFocused: Boolean); override;
|
||||
procedure ControlMouseDown(Sender: TObject; X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
function DoHandleMouseWheelByDefault: Boolean; override;
|
||||
public
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aFont: TKMFont; aStyle: TKMButtonStyle; aSelectable: Boolean = True);
|
||||
destructor Destroy; override;
|
||||
|
||||
procedure Add(const aItem: UnicodeString);
|
||||
procedure Clear;
|
||||
procedure ScrollToBottom;
|
||||
property WordWrap: Boolean read fWordWrap write SetWordWrap; //Whether to automatically wrap text within given text area width
|
||||
property IndentAfterNL: Boolean read fIndentAfterNL write fIndentAfterNL;
|
||||
property Text: UnicodeString read GetText write SetText;
|
||||
property ItemHeight: Byte read fItemHeight write fItemHeight;
|
||||
property TopIndex: Smallint read GetTopIndex write SetTopIndex;
|
||||
property ScrollDown: Boolean read fScrollDown write fScrollDown;
|
||||
property CursorPos: Integer read fCursorPos write SetCursorPos;
|
||||
property Selectable: Boolean read fSelectable write fSelectable;
|
||||
property SelectionStart: Integer read fSelectionStart write SetSelectionStart;
|
||||
property SelectionEnd: Integer read fSelectionEnd write SetSelectionEnd;
|
||||
|
||||
function GetVisibleRows: Integer;
|
||||
function KeyDown(Key: Word; Shift: TShiftState): Boolean; override;
|
||||
function KeyUp(Key: Word; Shift: TShiftState): Boolean; override;
|
||||
procedure MouseWheel(Sender: TObject; WheelSteps: Integer; var aHandled: Boolean); override;
|
||||
procedure MouseDown(X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
procedure MouseMove(X,Y: Integer; Shift: TShiftState); override;
|
||||
procedure MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
|
||||
property OnChange: TNotifyEvent read fOnChange write fOnChange;
|
||||
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
KM_Defaults,
|
||||
{$IFDEF MSWindows} Windows, {$ENDIF}
|
||||
{$IFDEF Unix} LCLIntf, LCLType, {$ENDIF}
|
||||
SysUtils, StrUtils, Math,
|
||||
Clipbrd,
|
||||
KromUtils,
|
||||
KM_ControlsUtils,
|
||||
KM_Resource, KM_Render, KM_RenderTypes,
|
||||
KM_CommonUtils;
|
||||
|
||||
|
||||
{ TKMMemo }
|
||||
constructor TKMMemo.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aFont: TKMFont; aStyle: TKMButtonStyle; aSelectable: Boolean = True);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
fItemHeight := 20;
|
||||
fItems := TStringList.Create;
|
||||
fFont := aFont;
|
||||
|
||||
fScrollBar := TKMScrollBar.Create(aParent, aLeft+aWidth-20, aTop, 20, aHeight, saVertical, aStyle);
|
||||
UpdateScrollBar; //Initialise the scrollbar
|
||||
fSelectable := aSelectable;
|
||||
|
||||
aParent.MasterControl.SubscribeOnOtherMouseDown(ControlMouseDown);
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMMemo.Destroy;
|
||||
begin
|
||||
fItems.Free;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.SetHeight(aValue: Integer);
|
||||
begin
|
||||
inherited;
|
||||
fScrollBar.Height := Height;
|
||||
UpdateScrollBar; //Since height has changed
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.SetWidth(aValue: Integer);
|
||||
begin
|
||||
inherited;
|
||||
fScrollBar.Left := Left + Width - fScrollBar.Width;
|
||||
ReformatText; //Repositions the scroll bar as well
|
||||
end;
|
||||
|
||||
|
||||
//Copy property to scrollbar. Otherwise it won't be rendered
|
||||
procedure TKMMemo.SetVisible(aValue: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
//Hide scrollbar and its buttons
|
||||
fScrollBar.Visible := IsSetVisible and (fScrollBar.MaxValue <> fScrollBar.MinValue);
|
||||
end;
|
||||
|
||||
|
||||
function TKMMemo.GetTopIndex: smallint;
|
||||
begin
|
||||
Result := fScrollBar.Position;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.SetTopIndex(aIndex: smallint);
|
||||
begin
|
||||
fScrollBar.Position := aIndex;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.SetEnabled(aValue: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
fScrollBar.Enabled := Enabled;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.SetTop(aValue: Integer);
|
||||
begin
|
||||
inherited;
|
||||
fScrollBar.Top := Top;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.SetWordWrap(const Value: boolean);
|
||||
begin
|
||||
fWordWrap := Value;
|
||||
ReformatText;
|
||||
end;
|
||||
|
||||
|
||||
function TKMMemo.GetText: UnicodeString;
|
||||
begin
|
||||
Result := fText;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.SetText(const aText: UnicodeString);
|
||||
begin
|
||||
fText := aText;
|
||||
ReformatText;
|
||||
|
||||
if Assigned(fOnChange) then
|
||||
fOnChange(Self);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.ReformatText;
|
||||
var
|
||||
newText: UnicodeString;
|
||||
begin
|
||||
if fWordWrap then
|
||||
newText := gRes.Fonts[fFont].WordWrap(fText, Width - fScrollBar.Width - 8, True, IndentAfterNL)
|
||||
else
|
||||
newText := fText;
|
||||
|
||||
//KaM uses | for new line, fItems.Text:= uses standard eol to parse each item from the string
|
||||
fItems.Text := StringReplace(newText, '|', EolW, [rfReplaceAll]);
|
||||
UpdateScrollBar;
|
||||
end;
|
||||
|
||||
|
||||
function TKMMemo.GetVisibleRows: Integer;
|
||||
begin
|
||||
Result := Height div fItemHeight;
|
||||
end;
|
||||
|
||||
|
||||
//fItems.Count or Height has changed
|
||||
procedure TKMMemo.UpdateScrollBar;
|
||||
var
|
||||
oldMax: Integer;
|
||||
begin
|
||||
oldMax := fScrollBar.MaxValue;
|
||||
fScrollBar.MaxValue := fItems.Count - GetVisibleRows;
|
||||
fScrollBar.Visible := IsSetVisible and (fScrollBar.MaxValue <> fScrollBar.MinValue);
|
||||
|
||||
if fScrollDown then
|
||||
begin
|
||||
if oldMax - fScrollBar.Position <= 2 then //If they were near the bottom BEFORE updating, keep them at the bottom
|
||||
SetTopIndex(fItems.Count) //This puts it at the bottom because of the EnsureRange in SetTopIndex
|
||||
end
|
||||
else
|
||||
SetTopIndex(fScrollBar.Position);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.SetCursorPos(aPos: Integer);
|
||||
begin
|
||||
fCursorPos := EnsureRange(aPos, 0, GetMaxCursorPos);
|
||||
end;
|
||||
|
||||
|
||||
function TKMMemo.GetPlainText(aUsePipeAsEOL: Boolean; aStart: Integer = -1; aEnd: Integer = -1): UnicodeString;
|
||||
begin
|
||||
if aStart = -1 then
|
||||
aStart := 0;
|
||||
|
||||
if aEnd = -1 then
|
||||
aEnd := Length(fItems.Text);
|
||||
|
||||
// First remove EOL's to get correct positions in text
|
||||
Result := StringReplace(fItems.Text, EolW, '|', [rfReplaceAll]);
|
||||
// Get text with selected positions, cleaned of color markup
|
||||
Result := Copy(GetNoColorMarkupText(Result), aStart + 1, aEnd - aStart);
|
||||
// Return EOL's back
|
||||
if not aUsePipeAsEOL then
|
||||
Result := StringReplace(Result, '|', EolW, [rfReplaceAll]);
|
||||
end;
|
||||
|
||||
|
||||
function TKMMemo.GetSelectedText: UnicodeString;
|
||||
begin
|
||||
Result := '';
|
||||
if HasSelection then
|
||||
Result := GetPlainText(False, fSelectionStart, fSelectionEnd);
|
||||
end;
|
||||
|
||||
|
||||
function TKMMemo.HasSelection: Boolean;
|
||||
begin
|
||||
Result := (fSelectionStart <> -1) and (fSelectionEnd <> -1) and (fSelectionStart <> fSelectionEnd);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.ResetSelection;
|
||||
begin
|
||||
fSelectionStart := -1;
|
||||
fSelectionEnd := -1;
|
||||
fSelectionInitialPos := -1;
|
||||
end;
|
||||
|
||||
|
||||
//We are using 2 systems for position: Linear (cumulative) and 'Point' (2D with column and row)
|
||||
//Every system have Length(RowText)+1 positions in every line
|
||||
//Convert Linear position into 2D position
|
||||
function TKMMemo.LinearToPointPos(aPos: Integer): TKMPoint;
|
||||
var I, row, column: Integer;
|
||||
rowText: UnicodeString;
|
||||
rowStartPos, rowEndPos: Integer;
|
||||
begin
|
||||
row := 0;
|
||||
column := 0;
|
||||
for I := 0 to fItems.Count - 1 do
|
||||
begin
|
||||
rowText := GetNoColorMarkupText(fItems[I]);
|
||||
rowStartPos := PointToLinearPos(0, I);
|
||||
rowEndPos := rowStartPos + Length(rowText);
|
||||
if InRange(aPos, rowStartPos, rowEndPos) then
|
||||
begin
|
||||
row := I;
|
||||
column := aPos - rowStartPos;
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
Result := TKMPoint.New(column, row);
|
||||
end;
|
||||
|
||||
|
||||
//We are using 2 systems for position: Linear (cumulative) and 'Point' (2D with column and row)
|
||||
//Every system have Length(RowText)+1 positions in every line
|
||||
//Convert 2D position into Linear position
|
||||
function TKMMemo.PointToLinearPos(aColumn, aRow: Integer): Integer;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
aRow := EnsureRange(aRow, 0, fItems.Count-1);
|
||||
for I := 0 to aRow-1 do
|
||||
Inc(Result, Length(GetNoColorMarkupText(fItems[I])) + 1); //+1 for special KaM new line symbol ('|')
|
||||
Inc(Result, EnsureRange(aColumn, 0, GetMaxPosInRow(aRow)));
|
||||
end;
|
||||
|
||||
|
||||
//Return position of Cursor in 2D of point X,Y on the screen
|
||||
function TKMMemo.GetCharPosAt(X,Y: Integer): TKMPoint;
|
||||
var
|
||||
row, column: Integer;
|
||||
begin
|
||||
row := 0;
|
||||
column := 0;
|
||||
|
||||
if fItems.Count > 0 then
|
||||
begin
|
||||
row := (EnsureRange(Y-AbsTop-3, 0, Height-6) div fItemHeight) + TopIndex;
|
||||
row := EnsureRange(row, 0, fItems.Count-1);
|
||||
column := gRes.Fonts[fFont].CharsThatFit(GetNoColorMarkupText(fItems[row]), X-AbsLeft-4);
|
||||
end;
|
||||
Result := TKMPoint.New(column, row);
|
||||
end;
|
||||
|
||||
|
||||
//Return position of Cursor in linear system of point X,Y on the screen
|
||||
function TKMMemo.GetCursorPosAt(X,Y: Integer): Integer;
|
||||
var
|
||||
charPos: TKMPoint;
|
||||
begin
|
||||
charPos := GetCharPosAt(X, Y);
|
||||
Result := PointToLinearPos(charPos.X, charPos.Y);
|
||||
end;
|
||||
|
||||
|
||||
// Maximum possible position of Cursor
|
||||
function TKMMemo.GetMaxCursorPos: Integer;
|
||||
begin
|
||||
Result := Length(StringReplace(fItems.Text, EolW, '', [rfReplaceAll])) + EnsureRange(fItems.Count-1, 0, fItems.Count);
|
||||
end;
|
||||
|
||||
|
||||
// Minimum possible position of Cursor in its current Row
|
||||
function TKMMemo.GetMinCursorPosInRow: Integer;
|
||||
begin
|
||||
Result := GetMinPosInRow(LinearToPointPos(CursorPos).Y)
|
||||
end;
|
||||
|
||||
|
||||
// Maximum possible position of Cursor in its current Row
|
||||
function TKMMemo.GetMaxCursorPosInRow: Integer;
|
||||
begin
|
||||
Result := GetMaxPosInRow(LinearToPointPos(CursorPos).Y)
|
||||
end;
|
||||
|
||||
|
||||
// Minimum possible position of Cursor in the specified aRow
|
||||
function TKMMemo.GetMinPosInRow(aRow: Integer): Integer;
|
||||
begin
|
||||
if aRow = 0 then
|
||||
Result := 0
|
||||
else
|
||||
Result := GetMaxPosInRow(aRow - 1) + 1;
|
||||
end;
|
||||
|
||||
|
||||
// Maximum possible position of Cursor in the specified aRow
|
||||
function TKMMemo.GetMaxPosInRow(aRow: Integer): Integer;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
for I := 0 to min(aRow, fItems.Count - 1) do
|
||||
Inc(Result, Length(GetNoColorMarkupText(fItems[I])) + 1);
|
||||
Result := EnsureRange(Result - 1, 0, Result);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.SetSelectionStart(aValue: Integer);
|
||||
var
|
||||
maxPos: Integer;
|
||||
begin
|
||||
if fSelectable then
|
||||
begin
|
||||
maxPos := GetMaxCursorPos;
|
||||
fSelectionStart := EnsureRange(aValue, 0, maxPos);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.SetSelectionEnd(aValue: Integer);
|
||||
var
|
||||
maxPos: Integer;
|
||||
begin
|
||||
if fSelectable then
|
||||
begin
|
||||
maxPos := GetMaxCursorPos;
|
||||
fSelectionEnd := EnsureRange(aValue, 0, maxPos);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
//Set selections with pair of value, using he fact, that fSelectionStart <= fSelectionEnd
|
||||
procedure TKMMemo.SetSelections(aValue1, aValue2: Integer);
|
||||
begin
|
||||
fSelectionStart := Min(aValue1, aValue2);
|
||||
fSelectionEnd := Max(aValue1, aValue2);
|
||||
end;
|
||||
|
||||
|
||||
//Update selection start/end due to change cursor position
|
||||
procedure TKMMemo.UpdateSelection(aOldCursorPos: Integer; aIsSelecting: Boolean);
|
||||
begin
|
||||
if aIsSelecting then
|
||||
begin
|
||||
if HasSelection then
|
||||
begin
|
||||
if aOldCursorPos = SelectionStart then
|
||||
SetSelections(CursorPos, SelectionEnd)
|
||||
else
|
||||
if aOldCursorPos = SelectionEnd then
|
||||
SetSelections(SelectionStart, CursorPos);
|
||||
end else
|
||||
SetSelections(aOldCursorPos, CursorPos);
|
||||
end
|
||||
else
|
||||
ResetSelection;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.Add(const aItem: UnicodeString);
|
||||
begin
|
||||
if fText <> '' then
|
||||
fText := fText + '|';
|
||||
|
||||
fText := fText + aItem; //Append the new string
|
||||
|
||||
SetText(fText); //Updates the text in fItems
|
||||
UpdateScrollBar; //Scroll down with each item that is added.
|
||||
|
||||
if Assigned(fOnChange) then
|
||||
fOnChange(Self);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.Clear;
|
||||
begin
|
||||
fText := '';
|
||||
fItems.Clear;
|
||||
ResetSelection;
|
||||
UpdateScrollBar;
|
||||
|
||||
if Assigned(fOnChange) then
|
||||
fOnChange(Self);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.ScrollToBottom;
|
||||
begin
|
||||
SetTopIndex(fItems.Count);
|
||||
end;
|
||||
|
||||
|
||||
//Key events which have no effect should not be handled (allows scrolling while chat window open with no text entered)
|
||||
function TKMMemo.KeyEventHandled(Key: Word; Shift: TShiftState): Boolean;
|
||||
begin
|
||||
Result := True;
|
||||
|
||||
//Don't include backspace/delete because edits should always handle those. Otherwise when you
|
||||
//press backspace repeatedly to remove all characters it will apply other shortcuts like
|
||||
//resetting the zoom if you press it once too many times.
|
||||
case Key of
|
||||
VK_UP,
|
||||
VK_DOWN,
|
||||
VK_LEFT,
|
||||
VK_RIGHT,
|
||||
VK_HOME,
|
||||
VK_END,
|
||||
VK_PRIOR,
|
||||
VK_NEXT: Result := (fText <> ''); //These keys have no effect when text is blank
|
||||
end;
|
||||
|
||||
//We want these keys to be ignored by chat, so game shortcuts still work
|
||||
if Key in [VK_F1..VK_F12, VK_ESCAPE, VK_MBUTTON] then Result := False;
|
||||
|
||||
//Ctrl can be used as an escape character, e.g. CTRL+B places beacon while chat is open
|
||||
if ssCtrl in Shift then Result := (Key in [VK_LEFT, VK_RIGHT, Ord('A'), Ord('C'), Ord('X')]);
|
||||
end;
|
||||
|
||||
|
||||
function TKMMemo.KeyDown(Key: Word; Shift: TShiftState): Boolean;
|
||||
//Move cursor vertically (change cursor row)
|
||||
procedure MoveCursorVertically(aRowIncrement: Integer);
|
||||
var
|
||||
cursorPointPos: TKMPoint;
|
||||
newCursorPosY: Integer;
|
||||
srcLineText, destLineText: UnicodeString;
|
||||
begin
|
||||
cursorPointPos := LinearToPointPos(CursorPos);
|
||||
newCursorPosY := EnsureRange(cursorPointPos.Y + aRowIncrement, 0, fItems.Count-1);
|
||||
if newCursorPosY <> cursorPointPos.Y then
|
||||
begin
|
||||
// Because we don't use monospaces fonts, then its better to find proper column, which depends of text width in px
|
||||
srcLineText := GetNoColorMarkupText(Copy(fItems[cursorPointPos.Y], 1, cursorPointPos.X));
|
||||
destLineText := GetNoColorMarkupText(fItems[newCursorPosY]);
|
||||
//Use 'rounding' version of CharsThatFit to get more precise position
|
||||
cursorPointPos.X := gRes.Fonts[fFont].CharsThatFit(destLineText, gRes.Fonts[fFont].GetTextSize(srcLineText).X, True);
|
||||
CursorPos := PointToLinearPos(cursorPointPos.X, newCursorPosY);
|
||||
// Update scroll position, if needed
|
||||
if TopIndex > newCursorPosY then
|
||||
TopIndex := newCursorPosY
|
||||
else if TopIndex < newCursorPosY - GetVisibleRows + 1 then
|
||||
TopIndex := newCursorPosY - GetVisibleRows + 1;
|
||||
end;
|
||||
end;
|
||||
|
||||
// Update cursor pos considering Ctrl Key to go to the next / prev word in the text
|
||||
procedure UpdateCursorPos(aCursorDir: TKMCursorDir);
|
||||
begin
|
||||
if ssCtrl in Shift then
|
||||
begin
|
||||
case aCursorDir of
|
||||
cdNone: ;
|
||||
cdForward: CursorPos := GetNextWordPos(GetPlainText(True), CursorPos);
|
||||
cdBack: CursorPos := GetPrevWordPos(GetPlainText(True), CursorPos);
|
||||
end;
|
||||
end
|
||||
else
|
||||
CursorPos := CursorPos + ShortInt(aCursorDir);
|
||||
end;
|
||||
|
||||
var
|
||||
oldCursorPos: Integer;
|
||||
isSelect: Boolean;
|
||||
begin
|
||||
Result := KeyEventHandled(Key, Shift);
|
||||
if inherited KeyDown(Key, Shift) then Exit;
|
||||
|
||||
//Clipboard operations
|
||||
if (Shift = [ssCtrl]) and (Key <> VK_CONTROL) then
|
||||
case Key of
|
||||
Ord('A'): SetSelections(0, GetMaxCursorPos);
|
||||
Ord('C'),
|
||||
Ord('X'): if HasSelection then
|
||||
Clipboard.AsText := GetSelectedText;
|
||||
end;
|
||||
|
||||
oldCursorPos := CursorPos;
|
||||
isSelect := IsSelecting(Key, Shift);
|
||||
|
||||
case Key of
|
||||
VK_LEFT,
|
||||
VK_RIGHT: begin
|
||||
UpdateCursorPos(GetCursorDir(Key));
|
||||
UpdateSelection(oldCursorPos, isSelect);
|
||||
end;
|
||||
VK_UP: begin
|
||||
MoveCursorVertically(-1);
|
||||
UpdateSelection(oldCursorPos, isSelect);
|
||||
end;
|
||||
VK_DOWN: begin
|
||||
MoveCursorVertically(1);
|
||||
UpdateSelection(oldCursorPos, isSelect);
|
||||
end;
|
||||
VK_PRIOR: begin
|
||||
MoveCursorVertically(-GetVisibleRows);
|
||||
UpdateSelection(oldCursorPos, isSelect);
|
||||
end;
|
||||
VK_NEXT: begin
|
||||
MoveCursorVertically(GetVisibleRows);
|
||||
UpdateSelection(oldCursorPos, isSelect);
|
||||
end;
|
||||
VK_HOME: begin
|
||||
CursorPos := GetMinCursorPosInRow;
|
||||
UpdateSelection(oldCursorPos, isSelect);
|
||||
end;
|
||||
VK_END: begin
|
||||
CursorPos := GetMaxCursorPosInRow;
|
||||
UpdateSelection(oldCursorPos, isSelect);
|
||||
end;
|
||||
end
|
||||
end;
|
||||
|
||||
|
||||
function TKMMemo.KeyUp(Key: Word; Shift: TShiftState): Boolean;
|
||||
begin
|
||||
Result := inherited KeyUp(Key, Shift) or KeyEventHandled(Key, Shift);
|
||||
end;
|
||||
|
||||
|
||||
function TKMMemo.DoHandleMouseWheelByDefault: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.MouseWheel(Sender: TObject; WheelSteps: Integer; var aHandled: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if aHandled then Exit;
|
||||
|
||||
SetTopIndex(TopIndex - WheelSteps);
|
||||
|
||||
aHandled := WheelSteps <> 0;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.MouseDown(X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
var
|
||||
oldCursorPos: Integer;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
Focusable := fSelectable and (fText <> ''); // Do not focus on empty Memo's
|
||||
// Update Focus now, because we need to focus on MouseDown, not on MouseUp as by default for all controls
|
||||
MasterParent.MasterControl.UpdateFocus(Self);
|
||||
|
||||
oldCursorPos := CursorPos;
|
||||
CursorPos := GetCursorPosAt(X, Y);
|
||||
|
||||
if Focusable then
|
||||
begin
|
||||
//Try select on Shift + LMB click
|
||||
UpdateSelection(oldCursorPos, (oldCursorPos <> -1) and (Shift = [ssLeft, ssShift]));
|
||||
fSelectionInitialPos := CursorPos;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.MouseMove(X,Y: Integer; Shift: TShiftState);
|
||||
var
|
||||
oldCursorPos: Integer;
|
||||
charPos: TKMPoint;
|
||||
begin
|
||||
inherited;
|
||||
if (ssLeft in Shift) and (fSelectionInitialPos <> -1) then
|
||||
begin
|
||||
charPos := GetCharPosAt(X, Y);
|
||||
|
||||
// To rotate text to top while selecting
|
||||
if (Y-AbsTop-3 < 0) and (TopIndex > 0) then
|
||||
begin
|
||||
Dec(charPos.Y);
|
||||
SetTopIndex(TopIndex-1);
|
||||
end;
|
||||
// To rotate text to bottom while selecting
|
||||
if (Y-AbsTop-3 > Height)
|
||||
and (fScrollBar.Position < fScrollBar.MaxValue) then
|
||||
begin
|
||||
charPos.Y := EnsureRange(charPos.Y+1, 0, fItems.Count);
|
||||
SetTopIndex(TopIndex+1);
|
||||
end;
|
||||
|
||||
oldCursorPos := CursorPos;
|
||||
CursorPos := PointToLinearPos(charPos.X, charPos.Y);;
|
||||
UpdateSelection(oldCursorPos, True);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
inherited;
|
||||
fSelectionInitialPos := -1;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.ControlMouseDown(Sender: TObject; X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
// Reset all, if other control was clicked
|
||||
if Sender <> Self then
|
||||
begin
|
||||
ResetSelection;
|
||||
Focusable := False;
|
||||
CursorPos := -1;
|
||||
MasterParent.MasterControl.UpdateFocus(Self);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.FocusChanged(aFocused: Boolean);
|
||||
begin
|
||||
if not aFocused then
|
||||
begin
|
||||
ResetSelection;
|
||||
CursorPos := -1;
|
||||
Focusable := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMemo.Paint;
|
||||
var
|
||||
I, paintWidth, selPaintTop, selPaintHeight: Integer;
|
||||
beforeSelectionText, selectionText, rowText: UnicodeString;
|
||||
beforeSelectionW, selectionW, selStartPosInRow, selEndPosInRow, rowStartPos, rowEndPos: Integer;
|
||||
offX, offY: Integer;
|
||||
begin
|
||||
inherited;
|
||||
if fScrollBar.Visible then
|
||||
paintWidth := Width - fScrollBar.Width //Leave space for scrollbar
|
||||
else
|
||||
paintWidth := Width; //List takes up the entire width
|
||||
|
||||
TKMRenderUI.WriteBevel(AbsLeft, AbsTop, paintWidth, Height, 1, 0.5);
|
||||
|
||||
for I := 0 to Math.min(fItems.Count-1, GetVisibleRows - 1) do
|
||||
begin
|
||||
rowText := GetNoColorMarkupText(fItems[TopIndex+I]);
|
||||
rowStartPos := PointToLinearPos(0, TopIndex+I);
|
||||
rowEndPos := rowStartPos + Length(rowText);
|
||||
if HasSelection then
|
||||
begin
|
||||
selStartPosInRow := fSelectionStart - rowStartPos;
|
||||
selEndPosInRow := fSelectionEnd - rowStartPos;
|
||||
|
||||
selStartPosInRow := EnsureRange(selStartPosInRow, 0, rowEndPos);
|
||||
selEndPosInRow := EnsureRange(selEndPosInRow, selStartPosInRow, rowEndPos);
|
||||
|
||||
if selStartPosInRow <> selEndPosInRow then
|
||||
begin
|
||||
beforeSelectionText := Copy(rowText, 1, selStartPosInRow);
|
||||
selectionText := Copy(rowText, selStartPosInRow+1, selEndPosInRow - selStartPosInRow);
|
||||
|
||||
beforeSelectionW := gRes.Fonts[fFont].GetTextSize(beforeSelectionText).X;
|
||||
selectionW := gRes.Fonts[fFont].GetTextSize(selectionText).X;
|
||||
|
||||
selPaintHeight := fItemHeight;
|
||||
selPaintTop := AbsTop+I*fItemHeight;
|
||||
if I = 0 then
|
||||
begin
|
||||
Dec(selPaintHeight, 3);
|
||||
Inc(selPaintTop, 3);
|
||||
end;
|
||||
|
||||
TKMRenderUI.WriteShape(AbsLeft+4+beforeSelectionW, selPaintTop, min(selectionW, Width-8), selPaintHeight, clTextSelection);
|
||||
end;
|
||||
end;
|
||||
|
||||
//Render text cursor
|
||||
if fSelectable and (csFocus in State) and ((TimeGet div 500) mod 2 = 0)
|
||||
and InRange(CursorPos, rowStartPos, rowEndPos) then
|
||||
begin
|
||||
offX := AbsLeft + 2 + gRes.Fonts[fFont].GetTextSize(Copy(rowText, 1, CursorPos-rowStartPos)).X;
|
||||
offY := AbsTop + 2 + I*fItemHeight;
|
||||
TKMRenderUI.WriteShape(offX, offY, 3, fItemHeight-4, $FFFFFFFF, $FF000000);
|
||||
end;
|
||||
TKMRenderUI.WriteText(AbsLeft+4, AbsTop+I*fItemHeight+3, Width-8, fItems.Strings[TopIndex+I] , fFont, taLeft);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
@@ -0,0 +1,339 @@
|
||||
unit KM_ControlsMinimapView;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, Controls,
|
||||
KromOGLUtils,
|
||||
KM_RenderUI, KM_Minimap, KM_Viewport,
|
||||
KM_ResFonts, KM_CommonTypes, KM_Points, KM_Defaults,
|
||||
KM_Controls, KM_ControlsBase;
|
||||
|
||||
|
||||
type
|
||||
TKMMinimapEvent = procedure (Sender: TObject; const aLocX, aLocY: Integer) of object;
|
||||
TKMMinimapLocEvent = procedure (Sender: TObject; const aLoc: Integer) of object;
|
||||
|
||||
// MinimapView relies on fMinimap and fViewport that provide all the data
|
||||
// MinimapView itself is just a painter
|
||||
TKMMinimapView = class(TKMControl)
|
||||
private
|
||||
fBevel: TKMBevel;
|
||||
fMinimap: TKMMinimap;
|
||||
fView: TKMViewport;
|
||||
fPaintWidth: Integer;
|
||||
fPaintHeight: Integer;
|
||||
fLeftOffset: Integer;
|
||||
fTopOffset: Integer;
|
||||
|
||||
fMapTex: TTexture;
|
||||
fWidthPOT: Word;
|
||||
fHeightPOT: Word;
|
||||
|
||||
fOnMinimapChange: TKMMinimapEvent;
|
||||
fOnMinimapClick: TKMMinimapEvent;
|
||||
fShowLocs: Boolean;
|
||||
fLocRad: Byte;
|
||||
fClickableOnce: Boolean;
|
||||
procedure UpdateTexture;
|
||||
procedure ResizeMinimap;
|
||||
protected
|
||||
procedure SetAnchors(aValue: TKMAnchorsSet); override;
|
||||
public
|
||||
OnMinimapLocationClick: TKMMinimapLocEvent;
|
||||
|
||||
constructor Create(aMinimap: TKMMinimap; aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aWithBevel: Boolean = False);
|
||||
|
||||
function LocalToMapCoords(X,Y: Integer): TKMPoint;
|
||||
function MapCoordsToLocal(X,Y: Single; const Inset: ShortInt = 0): TKMPoint;
|
||||
procedure UpdateSizes;
|
||||
procedure SetViewport(aViewport: TKMViewport);
|
||||
property ShowLocs: Boolean read fShowLocs write fShowLocs;
|
||||
property ClickableOnce: Boolean read fClickableOnce write fClickableOnce;
|
||||
property OnMinimapChange: TKMMinimapEvent write fOnMinimapChange;
|
||||
property OnMinimapClick: TKMMinimapEvent read fOnMinimapClick write fOnMinimapClick;
|
||||
|
||||
procedure MouseDown(X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
procedure MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
procedure MouseMove(X,Y: Integer; Shift: TShiftState); override;
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
SysUtils,
|
||||
Math,
|
||||
KromUtils,
|
||||
KM_MinimapGame,
|
||||
KM_Render, KM_RenderTypes,
|
||||
KM_CommonUtils,
|
||||
KM_GameSettings, KM_InterfaceTypes;
|
||||
|
||||
|
||||
{ TKMMinimapView }
|
||||
constructor TKMMinimapView.Create(aMinimap: TKMMinimap; aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aWithBevel: Boolean = False);
|
||||
begin
|
||||
//Create Bevel first
|
||||
if aWithBevel then
|
||||
fBevel := TKMBevel.Create(aParent, aLeft - 4, aTop - 4, aWidth + 8, aHeight + 8);
|
||||
|
||||
//Then Minimap control itself
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
|
||||
//Radius of circle around player location
|
||||
fLocRad := 8;
|
||||
|
||||
fMinimap := aMinimap;
|
||||
if fMinimap <> nil then
|
||||
begin
|
||||
fMinimap.SubOnUpdateTexture(UpdateTexture);
|
||||
fMinimap.SubOnResize(ResizeMinimap);
|
||||
|
||||
fMapTex.Tex := TKMRender.GenerateTextureCommon(ftNearest, ftNearest);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMinimapView.UpdateSizes;
|
||||
begin
|
||||
if fMinimap.MapX > fMinimap.MapY then
|
||||
begin
|
||||
fPaintWidth := Width;
|
||||
fPaintHeight := Round(Height * fMinimap.MapY / Max(fMinimap.MapX, 1)); // X could = 0
|
||||
fLeftOffset := 0;
|
||||
fTopOffset := (Height - fPaintHeight) div 2;
|
||||
end
|
||||
else
|
||||
begin
|
||||
fPaintWidth := Round(Width * fMinimap.MapX / Max(fMinimap.MapY, 1)); // Y could = 0
|
||||
fPaintHeight := Height;
|
||||
fLeftOffset := (Width - fPaintWidth) div 2;
|
||||
fTopOffset := 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMinimapView.SetViewport(aViewport: TKMViewport);
|
||||
begin
|
||||
fView := aViewport;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMinimapView.ResizeMinimap;
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
|
||||
fWidthPOT := MakePOT(fMinimap.MapX);
|
||||
fHeightPOT := MakePOT(fMinimap.MapY);
|
||||
fMapTex.U := fMinimap.MapX / fWidthPOT;
|
||||
fMapTex.V := fMinimap.MapY / fHeightPOT;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMinimapView.UpdateTexture;
|
||||
var
|
||||
wData: Pointer;
|
||||
I: Word;
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
|
||||
GetMem(wData, fWidthPOT * fHeightPOT * 4);
|
||||
|
||||
if fMinimap.MapY > 0 then //if MapY = 0 then loop will overflow to MaxWord
|
||||
for I := 0 to fMinimap.MapY - 1 do
|
||||
Move(Pointer(NativeUint(fMinimap.Base) + I * fMinimap.MapX * 4)^,
|
||||
Pointer(NativeUint(wData) + I * fWidthPOT * 4)^, fMinimap.MapX * 4);
|
||||
|
||||
TKMRender.UpdateTexture(fMapTex.Tex, fWidthPOT, fHeightPOT, tfRGBA8, wData);
|
||||
FreeMem(wData);
|
||||
|
||||
UpdateSizes;
|
||||
end;
|
||||
|
||||
|
||||
function TKMMinimapView.LocalToMapCoords(X,Y: Integer): TKMPoint;
|
||||
begin
|
||||
Result.X := EnsureRange(Trunc((X - AbsLeft - fLeftOffset) * (fMinimap.MapX + 1) / fPaintWidth), 1, fMinimap.MapX);
|
||||
Result.Y := EnsureRange(Trunc((Y - AbsTop - fTopOffset ) * (fMinimap.MapY + 1) / fPaintHeight), 1, fMinimap.MapY);
|
||||
end;
|
||||
|
||||
|
||||
function TKMMinimapView.MapCoordsToLocal(X,Y: Single; const Inset: ShortInt = 0): TKMPoint;
|
||||
begin
|
||||
Assert(Inset >= -1, 'Min allowed inset is -1, to be within TKMPoint range of 0..n');
|
||||
Result.X := AbsLeft + fLeftOffset + EnsureRange(Round(X * fPaintWidth / fMinimap.MapX), Inset, fPaintWidth - Inset);
|
||||
Result.Y := AbsTop + fTopOffset + EnsureRange(Round(Y * fPaintHeight / fMinimap.MapY), Inset, fPaintHeight - Inset);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMinimapView.SetAnchors(aValue: TKMAnchorsSet);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if fBevel <> nil then
|
||||
fBevel.Anchors := aValue;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMinimapView.MouseDown(X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
MouseMove(X,Y,Shift);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMinimapView.MouseMove(X,Y: Integer; Shift: TShiftState);
|
||||
var
|
||||
viewPos: TKMPoint;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if (ssLeft in Shift) and not fClickableOnce then
|
||||
begin
|
||||
viewPos := LocalToMapCoords(X,Y);
|
||||
if Assigned(fOnMinimapChange) then
|
||||
fOnMinimapChange(Self, viewPos.X, viewPos.Y);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMinimapView.MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
var
|
||||
I: Integer;
|
||||
T, viewPos: TKMPoint;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if fClickableOnce then
|
||||
begin
|
||||
fClickableOnce := False; //Not clickable anymore
|
||||
viewPos := LocalToMapCoords(X,Y);
|
||||
if Assigned(fOnMinimapClick) then
|
||||
fOnMinimapClick(Self, viewPos.X, viewPos.Y);
|
||||
end;
|
||||
|
||||
if fShowLocs then
|
||||
for I := 0 to MAX_HANDS - 1 do
|
||||
if fMinimap.HandShow[I] and not KMSamePoint(fMinimap.HandLocs[I], KMPOINT_ZERO) then
|
||||
begin
|
||||
T := MapCoordsToLocal(fMinimap.HandLocs[I].X, fMinimap.HandLocs[I].Y, fLocRad);
|
||||
if Sqr(T.X - X) + Sqr(T.Y - Y) < Sqr(fLocRad) then
|
||||
begin
|
||||
if Assigned(OnMinimapLocationClick) then
|
||||
OnMinimapLocationClick(Self, I);
|
||||
|
||||
// Do not repeat events for overlapping locations
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMMinimapView.Paint;
|
||||
const
|
||||
ALERT_RAD = 4;
|
||||
var
|
||||
I, K: Integer;
|
||||
R: TKMRect;
|
||||
S: TKMDirection4Set;
|
||||
T, T1, T2: TKMPoint;
|
||||
minimapGame: TKMMiniMapGame;
|
||||
miniLeft, miniTop, miniRight, miniBottom: SmallInt;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if (fMinimap = nil) or (fMinimap.MapX * fMinimap.MapY = 0) then
|
||||
Exit;
|
||||
|
||||
if (fMapTex.Tex <> 0) then
|
||||
TKMRenderUI.WriteTexture(AbsLeft + fLeftOffset, AbsTop + fTopOffset, fPaintWidth, fPaintHeight, fMapTex, $FFFFFFFF)
|
||||
else
|
||||
TKMRenderUI.WriteBevel(AbsLeft, AbsTop, Width, Height);
|
||||
|
||||
//Alerts (under viewport rectangle)
|
||||
if fMinimap is TKMMiniMapGame then
|
||||
begin
|
||||
minimapGame := TKMMiniMapGame(fMinimap);
|
||||
|
||||
if (minimapGame.Alerts <> nil) then
|
||||
for I := 0 to minimapGame.Alerts.Count - 1 do
|
||||
if minimapGame.Alerts[I].VisibleMinimap then
|
||||
begin
|
||||
T := MapCoordsToLocal(minimapGame.Alerts[I].Loc.X, minimapGame.Alerts[I].Loc.Y, ALERT_RAD);
|
||||
TKMRenderUI.WritePicture(T.X, T.Y, 0, 0, [],
|
||||
minimapGame.Alerts[I].TexMinimap.RX, minimapGame.Alerts[I].TexMinimap.ID,
|
||||
True, minimapGame.Alerts[I].TeamColor, Abs((TimeGet mod 1000) / 500 - 1));
|
||||
end;
|
||||
|
||||
//Viewport rectangle
|
||||
if fView <> nil then
|
||||
begin
|
||||
R := fView.GetMinimapClip;
|
||||
if (R.Right - R.Left) * (R.Bottom - R.Top) > 0 then
|
||||
begin
|
||||
if gGameSettings.ZoomBehaviour = zbRestricted then
|
||||
begin
|
||||
TKMRenderUI.WriteOutline(AbsLeft + fLeftOffset + Round((R.Left - 1)*fPaintWidth / fMinimap.MapX),
|
||||
AbsTop + fTopOffset + Round((R.Top - 1)*fPaintHeight / fMinimap.MapY),
|
||||
Round((R.Right - R.Left)*fPaintWidth / fMinimap.MapX),
|
||||
Round((R.Bottom - R.Top)*fPaintHeight / fMinimap.MapY), 1, $FFFFFFFF);
|
||||
end
|
||||
else
|
||||
begin
|
||||
miniLeft := AbsLeft + fLeftOffset + Round((R.Left - 1)*fPaintWidth / fMinimap.MapX) + 1;
|
||||
miniTop := AbsTop + fTopOffset + Round((R.Top - 1)*fPaintHeight / fMinimap.MapY) + 1;
|
||||
miniRight := AbsLeft + fLeftOffset + Round((R.Right - 1)*fPaintWidth / fMinimap.MapX);
|
||||
miniBottom := AbsTop + fTopOffset + Round((R.Bottom - 1)*fPaintHeight / fMinimap.MapY);
|
||||
|
||||
S := fView.GetMinimapClipLines;
|
||||
if drW in S then
|
||||
TKMRenderUI.WriteLine(miniLeft, miniBottom, miniLeft, miniTop, $FFFFFFFF);
|
||||
if drN in S then
|
||||
TKMRenderUI.WriteLine(miniLeft-1, miniTop, miniRight, miniTop, $FFFFFFFF);
|
||||
if drE in S then
|
||||
TKMRenderUI.WriteLine(miniRight, miniBottom, miniRight, miniTop, $FFFFFFFF);
|
||||
if drS in S then
|
||||
TKMRenderUI.WriteLine(miniLeft-1, miniBottom, miniRight, miniBottom, $FFFFFFFF);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
if fShowLocs then
|
||||
begin
|
||||
//Connect allied players
|
||||
for I := 0 to MAX_HANDS - 1 do
|
||||
if fMinimap.HandShow[I] and not KMSamePoint(fMinimap.HandLocs[I], KMPOINT_ZERO) then
|
||||
for K := I + 1 to MAX_HANDS - 1 do
|
||||
if fMinimap.HandShow[K] and not KMSamePoint(fMinimap.HandLocs[K], KMPOINT_ZERO) then
|
||||
if (fMinimap.HandTeam[I] <> 0) and (fMinimap.HandTeam[I] = fMinimap.HandTeam[K]) then
|
||||
begin
|
||||
T1 := MapCoordsToLocal(fMinimap.HandLocs[I].X, fMinimap.HandLocs[I].Y, fLocRad);
|
||||
T2 := MapCoordsToLocal(fMinimap.HandLocs[K].X, fMinimap.HandLocs[K].Y, fLocRad);
|
||||
TKMRenderUI.WriteLine(T1.X, T1.Y, T2.X, T2.Y, $FFFFFFFF);
|
||||
end;
|
||||
|
||||
//Draw all the circles, THEN all the numbers so the numbers are not covered by circles when they are close
|
||||
for I := 0 to MAX_HANDS - 1 do
|
||||
if fMinimap.HandShow[I] and not KMSamePoint(fMinimap.HandLocs[I], KMPOINT_ZERO) then
|
||||
begin
|
||||
T := MapCoordsToLocal(fMinimap.HandLocs[I].X, fMinimap.HandLocs[I].Y, fLocRad);
|
||||
TKMRenderUI.WriteCircle(T.X, T.Y, fLocRad, fMinimap.HandColors[I]);
|
||||
end;
|
||||
|
||||
for I := 0 to MAX_HANDS - 1 do
|
||||
if fMinimap.HandShow[I] and not KMSamePoint(fMinimap.HandLocs[I], KMPOINT_ZERO) then
|
||||
begin
|
||||
T := MapCoordsToLocal(fMinimap.HandLocs[I].X, fMinimap.HandLocs[I].Y, fLocRad);
|
||||
TKMRenderUI.WriteText(T.X, T.Y - 6, 0, IntToStr(I+1), fntOutline, taCenter);
|
||||
end;
|
||||
end;
|
||||
|
||||
if not Enabled then
|
||||
TKMRenderUI.WriteBevel(AbsLeft, AbsTop, Width+1, Height+1, 0, 0.5);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
+176
@@ -0,0 +1,176 @@
|
||||
unit KM_ControlsPopUp;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, Controls,
|
||||
KM_Controls, KM_ControlsBase, KM_ControlsList,
|
||||
KM_CommonTypes, KM_Points,
|
||||
KM_ResFonts;
|
||||
|
||||
|
||||
type
|
||||
TKMPopUpMenuMode = (
|
||||
pmActOnMouseUp, // Action triggered only by mouse up (default)
|
||||
pmActOnMouseDownNMove // Action triggered by mouse down and mouse move (drag)
|
||||
);
|
||||
|
||||
type
|
||||
// Popup with a short list (context menu)
|
||||
// For bigger taks - use TKMForm!
|
||||
TKMPopUpMenu = class(TKMPanel)
|
||||
private
|
||||
fMenuMode: TKMPopUpMenuMode;
|
||||
procedure MenuHide(Sender: TObject);
|
||||
procedure MenuActionTriggered(Sender: TObject);
|
||||
procedure HandleOtherControlMouseUp(Sender: TObject; X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
procedure SetItemIndex(aValue: Integer);
|
||||
function GetItemIndex: Integer;
|
||||
function GetItemTag(aIndex: Integer): Integer;
|
||||
protected
|
||||
Shape_Background: TKMShape;
|
||||
ColumnBox_List: TKMColumnBox;
|
||||
public
|
||||
constructor Create(aParent: TKMPanel; aWidth: Integer; aMenuMode: TKMPopUpMenuMode = pmActOnMouseUp);
|
||||
procedure AddItem(const aCaption: UnicodeString; aTag: Integer = 0);
|
||||
procedure UpdateItem(aIndex: Integer; const aCaption: UnicodeString);
|
||||
procedure Clear;
|
||||
property ItemIndex: Integer read GetItemIndex write SetItemIndex;
|
||||
property ItemTags[aIndex: Integer]: Integer read GetItemTag;
|
||||
procedure ShowAt(X,Y: Integer);
|
||||
procedure HideMenu;
|
||||
|
||||
property MenuMode: TKMPopUpMenuMode read fMenuMode;
|
||||
|
||||
procedure MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Math,
|
||||
KM_RenderUI;
|
||||
|
||||
|
||||
{ TKMPopUpMenu }
|
||||
constructor TKMPopUpMenu.Create(aParent: TKMPanel; aWidth: Integer; aMenuMode: TKMPopUpMenuMode = pmActOnMouseUp);
|
||||
begin
|
||||
inherited Create(aParent, 0, 0, aWidth, 0);
|
||||
|
||||
fMenuMode := aMenuMode;
|
||||
|
||||
// Note that Shape belongs to us, but we will manually position it to align with Parent to cover it
|
||||
Shape_Background := TKMShape.Create(Self, 0, 0, aParent.Width, aParent.Height);
|
||||
Shape_Background.OnClick := MenuHide;
|
||||
|
||||
ColumnBox_List := TKMColumnBox.Create(Self, 0, 0, aWidth, 0, fntGrey, bsMenu);
|
||||
ColumnBox_List.AnchorsStretch;
|
||||
ColumnBox_List.BackAlpha := 0.8;
|
||||
ColumnBox_List.Focusable := False;
|
||||
ColumnBox_List.SetColumns(fntGrey, [''], [0]);
|
||||
ColumnBox_List.ShowHeader := False;
|
||||
|
||||
case fMenuMode of
|
||||
pmActOnMouseUp: ColumnBox_List.OnClick := MenuActionTriggered;
|
||||
pmActOnMouseDownNMove: ColumnBox_List.OnChange := MenuActionTriggered;
|
||||
end;
|
||||
|
||||
fMasterControl.SubscribeOnOtherMouseUp(HandleOtherControlMouseUp);
|
||||
|
||||
Hide;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPopUpMenu.Clear;
|
||||
begin
|
||||
ColumnBox_List.Clear;
|
||||
end;
|
||||
|
||||
|
||||
function TKMPopUpMenu.GetItemIndex: Integer;
|
||||
begin
|
||||
Result := ColumnBox_List.ItemIndex;
|
||||
end;
|
||||
|
||||
|
||||
function TKMPopUpMenu.GetItemTag(aIndex: Integer): Integer;
|
||||
begin
|
||||
Result := ColumnBox_List.Rows[aIndex].Tag;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPopUpMenu.SetItemIndex(aValue: Integer);
|
||||
begin
|
||||
ColumnBox_List.ItemIndex := aValue;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPopUpMenu.AddItem(const aCaption: UnicodeString; aTag: Integer = 0);
|
||||
begin
|
||||
ColumnBox_List.AddItem(MakeListRow([aCaption], aTag));
|
||||
|
||||
// Set own height (and anchored List will follow)
|
||||
Height := ColumnBox_List.ItemHeight * ColumnBox_List.RowCount;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPopUpMenu.UpdateItem(aIndex: Integer; const aCaption: UnicodeString);
|
||||
begin
|
||||
ColumnBox_List.Rows[aIndex].Cells[0].Caption := aCaption;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPopUpMenu.MenuActionTriggered(Sender: TObject);
|
||||
begin
|
||||
if Assigned(OnClick) then
|
||||
OnClick(Self);
|
||||
|
||||
if fMenuMode = pmActOnMouseUp then
|
||||
HideMenu;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPopUpMenu.MenuHide(Sender: TObject);
|
||||
begin
|
||||
Hide;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPopUpMenu.HideMenu;
|
||||
begin
|
||||
MenuHide(nil);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPopUpMenu.ShowAt(X, Y: Integer);
|
||||
begin
|
||||
// Position self (and List will follow)
|
||||
AbsLeft := X;
|
||||
AbsTop := Y;
|
||||
|
||||
// Actualize modal background position
|
||||
Shape_Background.AbsLeft := Parent.AbsLeft;
|
||||
Shape_Background.AbsTop := Parent.AbsTop;
|
||||
|
||||
// Reset previously selected item
|
||||
ColumnBox_List.ItemIndex := -1;
|
||||
|
||||
Show;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPopUpMenu.HandleOtherControlMouseUp(Sender: TObject; X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
MouseUp(X, Y, Shift, Button);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPopUpMenu.MouseUp(X, Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
Hide;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
@@ -0,0 +1,350 @@
|
||||
unit KM_ControlsProgressBar;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Generics.Collections,
|
||||
KromOGLUtils,
|
||||
Classes, Controls,
|
||||
KM_Controls,
|
||||
KM_RenderUI,
|
||||
KM_ResFonts,
|
||||
KM_Points,
|
||||
KM_CommonTypes;
|
||||
|
||||
|
||||
type
|
||||
// Abstract Progress bar
|
||||
TKMProgressBarAbstract = class abstract(TKMControl)
|
||||
private
|
||||
fFont: TKMFont;
|
||||
fTextAlign: TKMTextAlign;
|
||||
protected
|
||||
procedure PaintBar; virtual; abstract;
|
||||
public
|
||||
//CaptionLeft and CaptionRight are shown to the left and right from main Caption. Use them only with taCenter
|
||||
Caption, CaptionLeft, CaptionRight: UnicodeString;
|
||||
FontColor: TColor4;
|
||||
TextYOffset: Integer;
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aFont: TKMFont = fntMini);
|
||||
procedure SetCaptions(const aCaptionLeft, aCaption, aCaptionRight: UnicodeString);
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
{Percent bar}
|
||||
TKMPercentBar = class(TKMProgressBarAbstract)
|
||||
private
|
||||
fPosition: Single;
|
||||
fSeam: Single;
|
||||
fMainColor: Cardinal;
|
||||
fAddColor: Cardinal;
|
||||
procedure SetPosition(aValue: Single);
|
||||
procedure SetSeam(aValue: Single);
|
||||
protected
|
||||
procedure PaintBar; override;
|
||||
public
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aFont: TKMFont = fntMini);
|
||||
property Seam: Single read fSeam write SetSeam;
|
||||
property Position: Single read fPosition write SetPosition;
|
||||
property MainColor: Cardinal read fMainColor write fMainColor;
|
||||
property AddColor: Cardinal read fAddColor write fAddColor;
|
||||
end;
|
||||
|
||||
|
||||
TKMReplayBar = class(TKMPercentBar)
|
||||
private
|
||||
fIsDirty: Boolean; //True is Marks are not not sorted yet
|
||||
fPosition: Integer;
|
||||
fPeacetime: Integer;
|
||||
fMaxValue: Integer;
|
||||
fHighlightMark: Integer;
|
||||
fMarks: TList<Integer>;
|
||||
fMarksPattern: Word;
|
||||
fOnMarkClick: TIntegerEvent;
|
||||
fHintResText: Word;
|
||||
procedure TrySortMarks;
|
||||
procedure SetPosition(aValue: Integer);
|
||||
procedure SetPeacetime(aValue: Integer);
|
||||
procedure SetMaxValue(aValue: Integer);
|
||||
protected
|
||||
procedure ControlMouseMove(Sender: TObject; X, Y: Integer; Shift: TShiftState);
|
||||
procedure PaintBar; override;
|
||||
public
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aFont: TKMFont = fntMini); overload;
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight, aPosition, aPeacetime, aMaxValue: Integer; aFont: TKMFont = fntMini); overload;
|
||||
destructor Destroy; override;
|
||||
|
||||
property Position: Integer read fPosition;
|
||||
property Peacetime: Integer read fPeacetime;
|
||||
property MaxValue: Integer read fMaxValue write SetMaxValue;
|
||||
|
||||
procedure SetParameters(aPosition, aPeacetime, aMaxValue: Integer);
|
||||
property MarksPattern: Word read fMarksPattern write fMarksPattern;
|
||||
property HintResText: Word read fHintResText write fHintResText;
|
||||
// property Marks: TList<Integer> read GetMarks;
|
||||
|
||||
procedure AddMark(aMark: Integer);
|
||||
procedure Clear;
|
||||
|
||||
property OnMarkClick: TIntegerEvent read fOnMarkClick write fOnMarkClick;
|
||||
|
||||
procedure MouseMove(X,Y: Integer; Shift: TShiftState); override;
|
||||
procedure MouseUp (X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
SysUtils,
|
||||
Math,
|
||||
KM_Resource, KM_ResTexts,
|
||||
KM_Defaults,
|
||||
KM_CommonUtils;
|
||||
|
||||
|
||||
{ TKMProgressBarAbstract }
|
||||
constructor TKMProgressBarAbstract.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aFont: TKMFont = fntMini);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
fFont := aFont;
|
||||
FontColor := $FFFFFFFF;
|
||||
fTextAlign := taCenter;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMProgressBarAbstract.SetCaptions(const aCaptionLeft, aCaption, aCaptionRight: UnicodeString);
|
||||
begin
|
||||
CaptionLeft := aCaptionLeft;
|
||||
Caption := aCaption;
|
||||
CaptionRight := aCaptionRight;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMProgressBarAbstract.Paint;
|
||||
var
|
||||
captionSize: TKMPoint;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
PaintBar;
|
||||
|
||||
//Now draw text over the bar, if it is required
|
||||
if Caption <> '' then
|
||||
begin
|
||||
//Shadow
|
||||
TKMRenderUI.WriteText(AbsLeft + 2, (AbsTop + Height div 2)+TextYOffset-4,
|
||||
Width-4, Caption, fFont, fTextAlign, $FF000000);
|
||||
//Text
|
||||
TKMRenderUI.WriteText(AbsLeft + 1, (AbsTop + Height div 2)+TextYOffset-5,
|
||||
Width-4, Caption, fFont, fTextAlign, FontColor);
|
||||
end;
|
||||
|
||||
if (CaptionLeft <> '') or (CaptionRight <> '') then
|
||||
captionSize := gRes.Fonts[fFont].GetTextSize(Caption);
|
||||
|
||||
if CaptionLeft <> '' then
|
||||
begin
|
||||
//Shadow
|
||||
TKMRenderUI.WriteText(AbsLeft + 2, (AbsTop + Height div 2)+TextYOffset-4,
|
||||
(Width-4 - captionSize.X) div 2, CaptionLeft, fFont, taRight, $FF000000);
|
||||
//Text
|
||||
TKMRenderUI.WriteText(AbsLeft + 1, (AbsTop + Height div 2)+TextYOffset-5,
|
||||
(Width-4 - captionSize.X) div 2, CaptionLeft, fFont, taRight, FontColor);
|
||||
end;
|
||||
|
||||
if CaptionRight <> '' then
|
||||
begin
|
||||
//Shadow
|
||||
TKMRenderUI.WriteText(AbsLeft + 2 + ((Width-4 + captionSize.X) div 2), (AbsTop + Height div 2)+TextYOffset-4,
|
||||
(Width-4 - captionSize.X) div 2, CaptionRight, fFont, taLeft, $FF000000);
|
||||
//Text
|
||||
TKMRenderUI.WriteText(AbsLeft + 1 + ((Width-4 + captionSize.X) div 2), (AbsTop + Height div 2)+TextYOffset-5,
|
||||
(Width-4 - captionSize.X) div 2, CaptionRight, fFont, taLeft, FontColor);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{ TKMPercentBar }
|
||||
constructor TKMPercentBar.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aFont: TKMFont = fntMini);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
fMainColor := icBarColorGreen;
|
||||
fAddColor := icBarColorBlue;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPercentBar.SetPosition(aValue: Single);
|
||||
begin
|
||||
fPosition := EnsureRange(aValue, 0, 1);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPercentBar.SetSeam(aValue: Single);
|
||||
begin
|
||||
fSeam := EnsureRange(aValue, 0, 1);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMPercentBar.PaintBar;
|
||||
begin
|
||||
TKMRenderUI.WritePercentBar(AbsLeft, AbsTop, Width, Height, fPosition, fSeam, fMainColor, fAddColor);
|
||||
end;
|
||||
|
||||
|
||||
{ TKMReplayBar }
|
||||
constructor TKMReplayBar.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aFont: TKMFont = fntMini);
|
||||
begin
|
||||
Create(aParent, aLeft, aTop, aWidth, aHeight, 0, MaxInt, MaxInt, aFont);
|
||||
end;
|
||||
|
||||
|
||||
constructor TKMReplayBar.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight, aPosition, aPeacetime, aMaxValue: Integer;
|
||||
aFont: TKMFont = fntMini);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight, aFont);
|
||||
|
||||
SetParameters(aPosition, aPeacetime, aMaxValue);
|
||||
fMarksPattern := $CF3; //Looks good for 25px height bar
|
||||
|
||||
fHighlightMark := -1;
|
||||
|
||||
fMarks := TList<Integer>.Create;
|
||||
|
||||
aParent.MasterControl.SubscribeOnOtherMouseMove(ControlMouseMove);
|
||||
end;
|
||||
|
||||
|
||||
destructor TKMReplayBar.Destroy;
|
||||
begin
|
||||
FreeAndNil(fMarks);
|
||||
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMReplayBar.SetParameters(aPosition, aPeacetime, aMaxValue: Integer);
|
||||
begin
|
||||
//Apply setters
|
||||
MaxValue := aMaxValue; //Should be first, since we restrict Position and PT with MaxValue
|
||||
SetPosition(aPosition);
|
||||
SetPeacetime(aPeacetime);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMReplayBar.AddMark(aMark: Integer);
|
||||
begin
|
||||
if Self = nil then Exit;
|
||||
|
||||
Assert(fMarks <> nil, 'Marks is not initilized');
|
||||
|
||||
fMarks.Add(aMark);
|
||||
fIsDirty := True;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMReplayBar.SetPosition(aValue: Integer);
|
||||
begin
|
||||
fPosition := EnsureRange(aValue, 0, fMaxValue);
|
||||
// Caption := IntToStr(fPosition);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMReplayBar.SetPeacetime(aValue: Integer);
|
||||
begin
|
||||
fPeacetime := EnsureRange(aValue, 0, MaxInt);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMReplayBar.SetMaxValue(aValue: Integer);
|
||||
begin
|
||||
fMaxValue := EnsureRange(aValue, 1, MaxInt);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMReplayBar.MouseMove(X,Y: Integer; Shift: TShiftState);
|
||||
const
|
||||
MAX_DIST_PERCENT = 0.02;
|
||||
var
|
||||
pos, bestDist, dist: Integer;
|
||||
mark, bestMark: Integer;
|
||||
begin
|
||||
inherited;
|
||||
pos := Round((X - AbsLeft) / Width * MaxValue);
|
||||
|
||||
bestDist := MaxInt;
|
||||
bestMark := -1;
|
||||
|
||||
TrySortMarks;
|
||||
for mark in fMarks do
|
||||
begin
|
||||
dist := Abs(pos - mark);
|
||||
if dist < MAX_DIST_PERCENT*fMaxValue then
|
||||
begin
|
||||
if dist < bestDist then
|
||||
begin
|
||||
bestDist := dist;
|
||||
bestMark := mark;
|
||||
end else
|
||||
Break; //List is sorted, we have found what we need
|
||||
end;
|
||||
end;
|
||||
|
||||
fHighlightMark := bestMark;
|
||||
|
||||
if fHighlightMark <> -1 then
|
||||
begin
|
||||
Hint := Format(gResTexts[fHintResText], [TickToTimeStr(fHighlightMark)]);
|
||||
// Caption := IntToStr(fPosition) + ' (' + IntToStr(fHighlightMark) + ')';
|
||||
end
|
||||
else
|
||||
begin
|
||||
Hint := '';
|
||||
// Caption := IntToStr(fPosition);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMReplayBar.MouseUp(X: Integer; Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if (fHighlightMark <> -1) and Assigned(fOnMarkClick) then
|
||||
fOnMarkClick(fHighlightMark);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMReplayBar.TrySortMarks;
|
||||
begin
|
||||
if fIsDirty then
|
||||
begin
|
||||
fIsDirty := False;
|
||||
fMarks.Sort;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMReplayBar.PaintBar;
|
||||
begin
|
||||
inherited;
|
||||
TKMRenderUI.WriteReplayBar(AbsLeft, AbsTop, Width, Height, fPosition, fPeacetime, fMaxValue, fMarks, MarksPattern, fHighlightMark);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMReplayBar.Clear;
|
||||
begin
|
||||
fMarks.Clear;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMReplayBar.ControlMouseMove(Sender: TObject; X, Y: Integer; Shift: TShiftState);
|
||||
begin
|
||||
inherited;
|
||||
if not InRange(X, AbsLeft, AbsRight)
|
||||
or not InRange(Y, AbsTop, AbsBottom) then
|
||||
fHighlightMark := -1;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
@@ -0,0 +1,823 @@
|
||||
unit KM_ControlsScroll;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, Controls,
|
||||
KM_Controls, KM_ControlsBase,
|
||||
KM_RenderUI,
|
||||
KM_Points;
|
||||
|
||||
|
||||
type
|
||||
TKMScrollAxis = (saVertical, saHorizontal);
|
||||
TKMScrollStyle = (ssGame, ssCommon);
|
||||
TKMScrollAxisSet = set of TKMScrollAxis;
|
||||
|
||||
TKMScrollBar = class(TKMPanel)
|
||||
private
|
||||
fScrollAxis: TKMScrollAxis;
|
||||
fStyle: TKMButtonStyle;
|
||||
fMinValue: Integer;
|
||||
fMaxValue: Integer;
|
||||
fPosition: Integer;
|
||||
fThumbPos: Integer; //Position of the thumb
|
||||
fThumbSize: Word; //Length of the thumb
|
||||
fOffset: Integer;
|
||||
fScrollDec: TKMButton;
|
||||
fScrollInc: TKMButton;
|
||||
fOnChange: TNotifyEvent;
|
||||
procedure SetMinValue(Value: Integer);
|
||||
procedure SetMaxValue(Value: Integer);
|
||||
procedure SetPosition(Value: Integer);
|
||||
procedure IncPosition(Sender: TObject);
|
||||
procedure DecPosition(Sender: TObject);
|
||||
procedure UpdateThumbPos;
|
||||
procedure UpdateThumbSize;
|
||||
protected
|
||||
procedure SetHeight(aValue: Integer); override;
|
||||
procedure SetWidth(aValue: Integer); override;
|
||||
procedure SetEnabled(aValue: Boolean); override;
|
||||
function DoHandleMouseWheelByDefault: Boolean; override;
|
||||
public
|
||||
BackAlpha: Single; //Alpha of background (usually 0.5, dropbox 1)
|
||||
EdgeAlpha: Single; //Alpha of background outline (usually 1)
|
||||
WheelStep: Word;
|
||||
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aScrollAxis: TKMScrollAxis;
|
||||
aStyle: TKMButtonStyle; aScrollStyle: TKMScrollStyle = ssGame);
|
||||
property MinValue: Integer read fMinValue write SetMinValue;
|
||||
property MaxValue: Integer read fMaxValue write SetMaxValue;
|
||||
property Position: Integer read fPosition write SetPosition;
|
||||
procedure MouseDown(X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
procedure MouseMove(X,Y: Integer; Shift: TShiftState); override;
|
||||
procedure MouseWheel(Sender: TObject; WheelSteps: Integer; var aHandled: Boolean); override;
|
||||
property OnChange: TNotifyEvent read fOnChange write fOnChange;
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
TKMScrollPanel = class(TKMPanel)
|
||||
private
|
||||
fChildsPanel: TKMPanel;
|
||||
|
||||
fClipRect: TKMRect;
|
||||
fScrollBarH: TKMScrollBar;
|
||||
fScrollBarV: TKMScrollBar;
|
||||
fScrollAxisSet: TKMScrollAxisSet;
|
||||
|
||||
fPadding: TKMRect;
|
||||
fScrollV_PadTop: Integer;
|
||||
fScrollV_PadBottom: Integer;
|
||||
fScrollV_PadLeft: Integer;
|
||||
|
||||
procedure UpdateScrolls(Sender: TObject; aValue: Boolean); overload;
|
||||
procedure UpdateScrolls(Sender: TObject); overload;
|
||||
procedure UpdateScrollV; overload;
|
||||
procedure UpdateScrollV(aChildsRect: TKMRect); overload;
|
||||
procedure UpdateScrollV(Sender: TObject; const aValue: Integer); overload;
|
||||
procedure UpdateScrollH; overload;
|
||||
procedure UpdateScrollH(aChildsRect: TKMRect); overload;
|
||||
procedure UpdateScrollH(Sender: TObject; const aValue: Integer); overload;
|
||||
procedure ScrollChanged(Sender: TObject);
|
||||
function GetChildsRect: TKMRect;
|
||||
|
||||
function AllowScrollV: Boolean;
|
||||
function AllowScrollH: Boolean;
|
||||
procedure SetScrollVPadTop(const Value: Integer);
|
||||
procedure SetScrollVPadBottom(const Value: Integer);
|
||||
|
||||
procedure SetScrollVPadLeft(const Value: Integer);
|
||||
protected
|
||||
procedure SetVisible(aValue: Boolean); override;
|
||||
procedure SetHitable(const aValue: Boolean); override;
|
||||
|
||||
procedure SetLeft(aValue: Integer); override;
|
||||
procedure SetTop(aValue: Integer); override;
|
||||
procedure SetHeight(aValue: Integer); override;
|
||||
procedure SetWidth(aValue: Integer); override;
|
||||
|
||||
function GetDrawRect: TKMRect; override;
|
||||
|
||||
function GetAbsDrawLeft: Integer; override;
|
||||
function GetAbsDrawTop: Integer; override;
|
||||
function GetAbsDrawRight: Integer; override;
|
||||
function GetAbsDrawBottom: Integer; override;
|
||||
|
||||
procedure UpdateVisibility; override;
|
||||
public
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aScrollAxisSet: TKMScrollAxisSet;
|
||||
aStyle: TKMButtonStyle; aScrollStyle: TKMScrollStyle);
|
||||
|
||||
property ScrollH: TKMScrollBar read fScrollBarH;
|
||||
property ScrollV: TKMScrollBar read fScrollBarV;
|
||||
|
||||
function AddChild(aChild: TKMControl): Integer; override;
|
||||
property ClipRect: TKMRect read fClipRect;
|
||||
property Padding: TKMRect read fPadding write fPadding;
|
||||
property ScrollV_PadTop: Integer read fScrollV_PadTop write SetScrollVPadTop;
|
||||
property ScrollV_PadLeft: Integer read fScrollV_PadLeft write SetScrollVPadLeft;
|
||||
property ScrollV_PadBottom: Integer read fScrollV_PadBottom write SetScrollVPadBottom;
|
||||
|
||||
procedure Show; override;
|
||||
|
||||
procedure MouseWheel(Sender: TObject; WheelSteps: Integer; var aHandled: Boolean); override;
|
||||
|
||||
procedure ClipY;
|
||||
procedure UnClipY;
|
||||
|
||||
procedure UpdateScrolls; overload;
|
||||
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
Math,
|
||||
KM_ResTypes;
|
||||
|
||||
|
||||
{ TKMScrollBar }
|
||||
constructor TKMScrollBar.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aScrollAxis: TKMScrollAxis;
|
||||
aStyle: TKMButtonStyle; aScrollStyle: TKMScrollStyle = ssGame);
|
||||
var
|
||||
decId, incId: Integer;
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
BackAlpha := 0.5;
|
||||
EdgeAlpha := 0.75;
|
||||
fScrollAxis := aScrollAxis;
|
||||
fMinValue := 0;
|
||||
fMaxValue := 10;
|
||||
fPosition := 0;
|
||||
fStyle := aStyle;
|
||||
WheelStep := 1;
|
||||
|
||||
if aScrollAxis = saVertical then
|
||||
begin
|
||||
fScrollDec := TKMButton.Create(Self, 0, 0, aWidth, aWidth, 591, rxGui, aStyle);
|
||||
fScrollInc := TKMButton.Create(Self, 0, aHeight-aWidth, aWidth, aWidth, 590, rxGui, aStyle);
|
||||
fScrollDec.Anchors := [anLeft, anTop, anRight];
|
||||
fScrollInc.Anchors := [anLeft, anRight, anBottom];
|
||||
end;
|
||||
if aScrollAxis = saHorizontal then
|
||||
begin
|
||||
if aScrollStyle = ssGame then
|
||||
begin
|
||||
decId := 2;
|
||||
incId := 3;
|
||||
end else begin
|
||||
decId := 674;
|
||||
incId := 675;
|
||||
end;
|
||||
fScrollDec := TKMButton.Create(Self, 0, 0, aHeight, aHeight, decId, rxGui, aStyle);
|
||||
fScrollInc := TKMButton.Create(Self, aWidth-aHeight, 0, aHeight, aHeight, incId, rxGui, aStyle);
|
||||
fScrollDec.Anchors := [anLeft, anTop, anBottom];
|
||||
fScrollInc.Anchors := [anTop, anRight, anBottom];
|
||||
end;
|
||||
fScrollDec.OnClick := DecPosition;
|
||||
fScrollDec.OnMouseWheel := MouseWheel;
|
||||
fScrollInc.OnClick := IncPosition;
|
||||
fScrollInc.OnMouseWheel := MouseWheel;
|
||||
UpdateThumbSize;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollBar.SetHeight(aValue: Integer);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
//Update Thumb size
|
||||
UpdateThumbSize;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollBar.SetWidth(aValue: Integer);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
//Update Thumb size
|
||||
UpdateThumbSize;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollBar.SetEnabled(aValue: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
fScrollDec.Enabled := Enabled;
|
||||
fScrollInc.Enabled := Enabled;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollBar.SetMinValue(Value: Integer);
|
||||
begin
|
||||
fMinValue := Max(0, Value);
|
||||
Enabled := (fMaxValue > fMinValue);
|
||||
SetPosition(fPosition);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollBar.SetMaxValue(Value: Integer);
|
||||
begin
|
||||
fMaxValue := Max(0, Value);
|
||||
Enabled := (fMaxValue > fMinValue);
|
||||
SetPosition(fPosition);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollBar.SetPosition(Value: Integer);
|
||||
begin
|
||||
fPosition := EnsureRange(Value, fMinValue, fMaxValue);
|
||||
UpdateThumbPos;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollBar.IncPosition(Sender: TObject);
|
||||
begin
|
||||
SetPosition(fPosition + WheelStep);
|
||||
|
||||
if Assigned(fOnChange) then
|
||||
fOnChange(Self);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollBar.DecPosition(Sender: TObject);
|
||||
begin
|
||||
SetPosition(fPosition - WheelStep);
|
||||
|
||||
if Assigned(fOnChange) then
|
||||
fOnChange(Self);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollBar.UpdateThumbPos;
|
||||
begin
|
||||
fThumbPos := 0;
|
||||
|
||||
if fMaxValue > fMinValue then
|
||||
case fScrollAxis of
|
||||
saVertical: fThumbPos := (fPosition-fMinValue)*(Height-Width*2-fThumbSize) div (fMaxValue-fMinValue);
|
||||
saHorizontal: fThumbPos := (fPosition-fMinValue)*(Width-Height*2-fThumbSize) div (fMaxValue-fMinValue);
|
||||
end
|
||||
else
|
||||
case fScrollAxis of
|
||||
saVertical: fThumbPos := Math.max((Height-Width*2-fThumbSize),0) div 2;
|
||||
saHorizontal: fThumbPos := Math.max((Width-Height*2-fThumbSize),0) div 2;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollBar.UpdateThumbSize;
|
||||
begin
|
||||
case fScrollAxis of
|
||||
saVertical: fThumbSize := Math.max(0, (Height-2*Width)) div 4;
|
||||
saHorizontal: fThumbSize := Math.max(0, (Width-2*Height)) div 4;
|
||||
end;
|
||||
|
||||
//If size has changed, then Pos needs to be updated as well (depends on it)
|
||||
UpdateThumbPos;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollBar.MouseDown(X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
var
|
||||
T: Integer;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
fOffset := 0;
|
||||
case fScrollAxis of
|
||||
saVertical: begin
|
||||
T := Y - AbsTop - Width - fThumbPos;
|
||||
if InRange(T, 0, fThumbSize) then
|
||||
fOffset := T - fThumbSize div 2;
|
||||
end;
|
||||
saHorizontal: begin
|
||||
T := X - AbsLeft - Height - fThumbPos;
|
||||
if InRange(T, 0, fThumbSize) then
|
||||
fOffset := T - fThumbSize div 2;
|
||||
end;
|
||||
end;
|
||||
|
||||
MouseMove(X,Y,Shift); //Will change Position and call OnChange event
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollBar.MouseMove(X,Y: Integer; Shift: TShiftState);
|
||||
var
|
||||
newPos: Integer;
|
||||
T: Integer;
|
||||
begin
|
||||
inherited;
|
||||
if not (ssLeft in Shift) then Exit;
|
||||
|
||||
newPos := fPosition;
|
||||
|
||||
case fScrollAxis of
|
||||
saVertical:
|
||||
begin
|
||||
T := Y - fOffset - AbsTop - Width;
|
||||
if InRange(T, 0, Height - Width * 2) then
|
||||
newPos := Round(fMinValue+((T - fThumbSize / 2) / (Height-Width*2-fThumbSize)) * (fMaxValue - fMinValue) );
|
||||
end;
|
||||
|
||||
saHorizontal:
|
||||
begin
|
||||
T := X - fOffset - AbsLeft - Height;
|
||||
if InRange(T, 0, Width - Height * 2) then
|
||||
newPos := Round(fMinValue+((T - fThumbSize / 2) / (Width-Height*2-fThumbSize)) * (fMaxValue - fMinValue) );
|
||||
end;
|
||||
end;
|
||||
|
||||
if newPos <> fPosition then
|
||||
begin
|
||||
SetPosition(newPos);
|
||||
if Assigned(fOnChange) then
|
||||
fOnChange(Self);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMScrollBar.DoHandleMouseWheelByDefault: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollBar.MouseWheel(Sender: TObject; WheelSteps: Integer; var aHandled: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if aHandled then Exit;
|
||||
|
||||
aHandled := WheelSteps <> 0;
|
||||
|
||||
if aHandled then
|
||||
begin
|
||||
Position := Position - WheelStep * WheelSteps;
|
||||
|
||||
if Assigned(fOnChange) then
|
||||
fOnChange(Self);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollBar.Paint;
|
||||
var
|
||||
buttonState: TKMButtonStateSet;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
case fScrollAxis of
|
||||
saVertical: TKMRenderUI.WriteBevel(AbsLeft, AbsTop+Width, Width, Height - Width*2, EdgeAlpha, BackAlpha);
|
||||
saHorizontal: TKMRenderUI.WriteBevel(AbsLeft+Height, AbsTop, Width - Height*2, Height, EdgeAlpha, BackAlpha);
|
||||
end;
|
||||
|
||||
if fMaxValue > fMinValue then
|
||||
buttonState := []
|
||||
else
|
||||
buttonState := [bsDisabled];
|
||||
|
||||
if not (bsDisabled in buttonState) then //Only show thumb when usable
|
||||
case fScrollAxis of
|
||||
saVertical: TKMRenderUI.Write3DButton(AbsLeft,AbsTop+Width+fThumbPos,Width,fThumbSize,rxGui,0,$FFFF00FF,buttonState,fStyle);
|
||||
saHorizontal: TKMRenderUI.Write3DButton(AbsLeft+Height+fThumbPos,AbsTop,fThumbSize,Height,rxGui,0,$FFFF00FF,buttonState,fStyle);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{ TKMScrollPanel }
|
||||
constructor TKMScrollPanel.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aScrollAxisSet: TKMScrollAxisSet;
|
||||
aStyle: TKMButtonStyle; aScrollStyle: TKMScrollStyle);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
|
||||
fPadding := KMRect(0, 0, 0, 0);
|
||||
|
||||
fScrollAxisSet := aScrollAxisSet;
|
||||
|
||||
fChildsPanel := TKMPanel.Create(Self, aLeft, aTop, aWidth, aHeight);
|
||||
fChildsPanel.AnchorsStretch;
|
||||
fChildsPanel.IsHitTestUseDrawRect := True; // We want DrawRect to be used on the ScrollPanel
|
||||
|
||||
// We should create scroll bars on Parent panel, since we move panel there and back and scroll should not be scrolled as well
|
||||
fScrollBarH := TKMScrollBar.Create(aParent, aLeft, aTop + aHeight - 20, aWidth, 20, saHorizontal, aStyle, aScrollStyle);
|
||||
fScrollBarH.Hide;
|
||||
fScrollBarH.OnChange := ScrollChanged;
|
||||
fScrollBarH.WheelStep := 10;
|
||||
|
||||
fScrollBarV := TKMScrollBar.Create(aParent, aLeft + aWidth - 20, aTop, 20, aHeight, saVertical, aStyle, aScrollStyle);
|
||||
fScrollBarV.Hide;
|
||||
fScrollBarV.OnChange := ScrollChanged;
|
||||
fScrollBarV.WheelStep := 10;
|
||||
|
||||
IsHitTestUseDrawRect := True; // We want DrawRect to be used on the ScrollPanel
|
||||
|
||||
fScrollV_PadTop := 0;
|
||||
fScrollV_PadBottom := 0;
|
||||
|
||||
fClipRect := KMRect(Left, Top, Right, Bottom);
|
||||
end;
|
||||
|
||||
|
||||
function TKMScrollPanel.AddChild(aChild: TKMControl): Integer;
|
||||
begin
|
||||
aChild.IsHitTestUseDrawRect := True;
|
||||
if fChildsPanel = nil then
|
||||
Result := inherited AddChild(aChild)
|
||||
else
|
||||
begin
|
||||
Result := fChildsPanel.AddChild(aChild);
|
||||
|
||||
aChild.OnHeightChange := UpdateScrollV;
|
||||
aChild.OnWidthChange := UpdateScrollH;
|
||||
aChild.OnPositionSet := UpdateScrolls;
|
||||
aChild.OnChangeVisibility := UpdateScrolls;
|
||||
aChild.OnChangeEnableStatus := UpdateScrolls;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
//Update View is usefull when use Padding Left or Top
|
||||
//To show panel properly initially. Beeter to invoke from Show Element
|
||||
procedure TKMScrollPanel.UpdateVisibility;
|
||||
begin
|
||||
inherited;
|
||||
if Visible
|
||||
and ((fPadding.Left > 0) or (fPadding.Top > 0)) then //Update visibility only when left/top padding > 0
|
||||
begin
|
||||
if saHorizontal in fScrollAxisSet then
|
||||
begin
|
||||
fScrollBarH.Position := fPadding.Left;
|
||||
ScrollChanged(fScrollBarH);
|
||||
end;
|
||||
|
||||
if saVertical in fScrollAxisSet then
|
||||
begin
|
||||
fScrollBarV.Position := fPadding.Top;
|
||||
ScrollChanged(fScrollBarV);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.MouseWheel(Sender: TObject; WheelSteps: Integer; var aHandled: Boolean);
|
||||
begin
|
||||
if (saVertical in fScrollAxisSet) and fScrollBarV.Visible then
|
||||
fScrollBarV.MouseWheel(Sender, WheelSteps, aHandled)
|
||||
else if (saHorizontal in fScrollAxisSet) and fScrollBarH.Visible then
|
||||
fScrollBarH.MouseWheel(Sender, WheelSteps, aHandled)
|
||||
else
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.ScrollChanged(Sender: TObject);
|
||||
var
|
||||
oldValue: Integer;
|
||||
begin
|
||||
if Sender = fScrollBarH then
|
||||
begin
|
||||
oldValue := Left;
|
||||
Left := fClipRect.Left - fScrollBarH.Position + fPadding.Left;
|
||||
//To compensate changes in SetLeft
|
||||
Inc(fClipRect.Left, oldValue - Left);
|
||||
Inc(fClipRect.Right, oldValue - Left);
|
||||
end else
|
||||
if Sender = fScrollBarV then
|
||||
begin
|
||||
oldValue := Top;
|
||||
Top := fClipRect.Top - fScrollBarV.Position + fPadding.Top;
|
||||
//To compensate changes in SetTop
|
||||
Inc(fClipRect.Top, oldValue - Top);
|
||||
Inc(fClipRect.Bottom, oldValue - Top);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.UpdateScrolls(Sender: TObject; aValue: Boolean);
|
||||
begin
|
||||
// No need to update scrolls if panel is not visible
|
||||
// In case we've just hide panel then DrawRect is RECT_ZERO and scrools will be set to 0 position
|
||||
if not Visible then Exit;
|
||||
|
||||
if (Sender <> fScrollBarH) and (Sender <> fScrollBarV) then
|
||||
UpdateScrolls(nil);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.UpdateScrollH(Sender: TObject; const aValue: Integer);
|
||||
begin
|
||||
if (Sender <> fScrollBarH) then
|
||||
UpdateScrollH;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.UpdateScrollH;
|
||||
begin
|
||||
if not (saHorizontal in fScrollAxisSet) then Exit;
|
||||
|
||||
UpdateScrollH(GetChildsRect);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.UpdateScrollH(aChildsRect: TKMRect);
|
||||
var
|
||||
newPos: Integer;
|
||||
showScroll: Boolean;
|
||||
begin
|
||||
if not (saHorizontal in fScrollAxisSet) then Exit;
|
||||
|
||||
showScroll := False;
|
||||
|
||||
if aChildsRect.Width + fPadding.Left + fPadding.Right > fClipRect.Width then
|
||||
begin
|
||||
fScrollBarH.MaxValue := aChildsRect.Width - fClipRect.Width + fPadding.Left + fPadding.Right;
|
||||
newPos := fClipRect.Left - Left;
|
||||
|
||||
if newPos > fScrollBarH.MaxValue then
|
||||
SetLeftSilently(Left + newPos - fScrollBarH.MaxValue); //Slightly move panel to the top, when resize near maxvalue position
|
||||
showScroll := True;
|
||||
end else begin
|
||||
fScrollBarH.Position := 0;
|
||||
if Left <> fClipRect.Left then
|
||||
SetLeftSilently(fClipRect.Left); //Set directrly to avoid SetLeft call
|
||||
end;
|
||||
|
||||
fScrollBarH.Width := Width;
|
||||
if showScroll <> fScrollBarH.Visible then
|
||||
begin
|
||||
fScrollBarH.Visible := showScroll;
|
||||
fChildsPanel.Height := Height - 20*Byte(showScroll);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.UpdateScrollV(Sender: TObject; const aValue: Integer);
|
||||
begin
|
||||
if (Sender <> fScrollBarV) then
|
||||
UpdateScrollV;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.UpdateScrollV;
|
||||
begin
|
||||
if not (saVertical in fScrollAxisSet) then Exit;
|
||||
|
||||
UpdateScrollV(GetChildsRect);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.UpdateScrollV(aChildsRect: TKMRect);
|
||||
var
|
||||
newPos: Integer;
|
||||
showScroll: Boolean;
|
||||
begin
|
||||
if not (saVertical in fScrollAxisSet) then Exit;
|
||||
|
||||
//Do not set Visible, avoid trigger OnChangeVisibility
|
||||
showScroll := False;
|
||||
|
||||
if aChildsRect.Height + fPadding.Top + fPadding.Bottom > fClipRect.Height then
|
||||
begin
|
||||
fScrollBarV.MaxValue := aChildsRect.Height - fClipRect.Height + fPadding.Top + fPadding.Bottom;
|
||||
newPos := fClipRect.Top - Top;
|
||||
|
||||
if newPos > fScrollBarV.MaxValue then
|
||||
SetTopSilently(Top + newPos - fScrollBarV.MaxValue); //Slightly move panel to the top, when resize near maxvalue position
|
||||
showScroll := True;
|
||||
end else begin
|
||||
fScrollBarV.Position := 0;
|
||||
if Top <> fClipRect.Top then
|
||||
SetTopSilently(fClipRect.Top); //Set directrly to avoid SetTop call
|
||||
end;
|
||||
|
||||
fScrollBarV.Height := Height - fScrollV_PadTop - fScrollV_PadBottom;
|
||||
if showScroll <> fScrollBarV.Visible then
|
||||
begin
|
||||
fScrollBarV.Visible := showScroll;
|
||||
fChildsPanel.Width := Width - 20*Byte(showScroll);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.UpdateScrolls;
|
||||
begin
|
||||
UpdateScrolls(nil);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.UpdateScrolls(Sender: TObject);
|
||||
var
|
||||
childsRect: TKMRect;
|
||||
begin
|
||||
childsRect := GetChildsRect;
|
||||
|
||||
UpdateScrollV(childsRect);
|
||||
UpdateScrollH(childsRect);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.SetLeft(aValue: Integer);
|
||||
var
|
||||
oldValue: Integer;
|
||||
begin
|
||||
oldValue := Left;
|
||||
inherited;
|
||||
|
||||
Inc(fClipRect.Left, Left - oldValue);
|
||||
Inc(fClipRect.Right, Left - oldValue);
|
||||
|
||||
UpdateScrolls(nil);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.SetScrollVPadBottom(const Value: Integer);
|
||||
begin
|
||||
fScrollV_PadBottom := Value;
|
||||
fScrollBarV.Height := fScrollBarV.Height - Value;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.SetScrollVPadLeft(const Value: Integer);
|
||||
begin
|
||||
fScrollV_PadLeft := Value;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.SetScrollVPadTop(const Value: Integer);
|
||||
begin
|
||||
fScrollV_PadTop := Value;
|
||||
fScrollBarV.Top := fScrollBarV.Top + Value;
|
||||
fScrollBarV.Height := fScrollBarV.Height - Value;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.SetTop(aValue: Integer);
|
||||
var
|
||||
oldValue: Integer;
|
||||
begin
|
||||
oldValue := Top;
|
||||
inherited;
|
||||
|
||||
Inc(fClipRect.Top, Top - oldValue);
|
||||
Inc(fClipRect.Bottom, Top - oldValue);
|
||||
|
||||
UpdateScrolls(nil);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.SetVisible(aValue: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
// Hide ScrollBars with if we hide ScrollPanel
|
||||
if not aValue then
|
||||
begin
|
||||
fScrollBarH.Visible := aValue;
|
||||
fScrollBarV.Visible := aValue;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.SetWidth(aValue: Integer);
|
||||
var
|
||||
oldValue: Integer;
|
||||
begin
|
||||
oldValue := Width;
|
||||
inherited;
|
||||
|
||||
Inc(fClipRect.Right, Width - oldValue);
|
||||
|
||||
fScrollBarV.Left := fClipRect.Left + Width + fScrollV_PadLeft;
|
||||
|
||||
UpdateScrolls(nil);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.Show;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
// We can use Visible here, since Self is he parent of ChildsPanel
|
||||
fChildsPanel.Visible := True;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.SetHeight(aValue: Integer);
|
||||
var
|
||||
oldValue: Integer;
|
||||
begin
|
||||
oldValue := Height;
|
||||
inherited;
|
||||
|
||||
Inc(fClipRect.Bottom, Height - oldValue);
|
||||
|
||||
fScrollBarH.Top := fClipRect.Top + Height;
|
||||
|
||||
UpdateScrolls(nil);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.SetHitable(const aValue: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
fChildsPanel.Hitable := aValue;
|
||||
end;
|
||||
|
||||
|
||||
function TKMScrollPanel.GetChildsRect: TKMRect;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
Result := KMRECT_ZERO; //Zero rect, by default
|
||||
|
||||
for I := 0 to fChildsPanel.ChildCount - 1 do
|
||||
begin
|
||||
if not fChildsPanel.Childs[I].IsPainted then
|
||||
Continue;
|
||||
|
||||
if fChildsPanel.Childs[I].Left < Result.Left then
|
||||
Result.Left := fChildsPanel.Childs[I].Left;
|
||||
|
||||
if fChildsPanel.Childs[I].Top < Result.Top then
|
||||
Result.Top := fChildsPanel.Childs[I].Top;
|
||||
|
||||
if fChildsPanel.Childs[I].Right > Result.Right then
|
||||
Result.Right := fChildsPanel.Childs[I].Right;
|
||||
|
||||
if fChildsPanel.Childs[I].Bottom > Result.Bottom then
|
||||
Result.Bottom := fChildsPanel.Childs[I].Bottom;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMScrollPanel.AllowScrollV: Boolean;
|
||||
begin
|
||||
Result := saVertical in fScrollAxisSet;
|
||||
end;
|
||||
|
||||
|
||||
function TKMScrollPanel.AllowScrollH: Boolean;
|
||||
begin
|
||||
Result := saHorizontal in fScrollAxisSet;
|
||||
end;
|
||||
|
||||
|
||||
function TKMScrollPanel.GetDrawRect: TKMRect;
|
||||
begin
|
||||
Result := KMRect(AbsDrawLeft, AbsDrawTop, AbsDrawRight, AbsDrawBottom);
|
||||
end;
|
||||
|
||||
|
||||
function TKMScrollPanel.GetAbsDrawLeft: Integer;
|
||||
begin
|
||||
Result := Parent.AbsLeft + fClipRect.Left;
|
||||
end;
|
||||
|
||||
|
||||
function TKMScrollPanel.GetAbsDrawTop: Integer;
|
||||
begin
|
||||
Result := Parent.AbsTop + fClipRect.Top;
|
||||
end;
|
||||
|
||||
|
||||
function TKMScrollPanel.GetAbsDrawRight: Integer;
|
||||
begin
|
||||
Result := Parent.AbsLeft + fClipRect.Right + 20*Byte(AllowScrollV and not fScrollBarV.Visible);
|
||||
end;
|
||||
|
||||
|
||||
function TKMScrollPanel.GetAbsDrawBottom: Integer;
|
||||
begin
|
||||
Result := Parent.AbsTop + fClipRect.Bottom + 20*Byte(AllowScrollH and not fScrollBarH.Visible);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.Paint;
|
||||
begin
|
||||
TKMRenderUI.SetupClipX(AbsDrawLeft, AbsDrawRight);
|
||||
TKMRenderUI.SetupClipY(AbsDrawTop, AbsDrawBottom);
|
||||
|
||||
inherited;
|
||||
|
||||
TKMRenderUI.ReleaseClipY;
|
||||
TKMRenderUI.ReleaseClipX;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.ClipY;
|
||||
begin
|
||||
TKMRenderUI.SetupClipY(AbsDrawTop, AbsDrawBottom);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMScrollPanel.UnClipY;
|
||||
begin
|
||||
TKMRenderUI.ReleaseClipY;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
@@ -0,0 +1,455 @@
|
||||
unit KM_ControlsSwitch;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, Controls,
|
||||
KromOGLUtils,
|
||||
KM_Controls,
|
||||
KM_ResFonts;
|
||||
|
||||
|
||||
type
|
||||
TKMCheckBoxState = (cbsUnchecked, cbsSemiChecked, cbsChecked);
|
||||
|
||||
{ Checkbox }
|
||||
TKMCheckBox = class(TKMControl)
|
||||
private
|
||||
fCaption: UnicodeString;
|
||||
fState: TKMCheckBoxState;
|
||||
fHasSemiState: Boolean;
|
||||
fFont: TKMFont;
|
||||
|
||||
function GetCheckedBool: Boolean;
|
||||
public
|
||||
DrawOutline: Boolean;
|
||||
LineColor: TColor4; //color of outline
|
||||
LineWidth: Byte;
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; const aCaption: UnicodeString;
|
||||
aFont: TKMFont; aHasSemiState: Boolean = False); overload;
|
||||
property Caption: UnicodeString read fCaption write fCaption;
|
||||
procedure SetChecked(aChecked: Boolean);
|
||||
property Checked: Boolean read GetCheckedBool write SetChecked;
|
||||
property CheckState: TKMCheckBoxState read fState write fState;
|
||||
function IsSemiChecked: Boolean;
|
||||
procedure Check;
|
||||
procedure Uncheck;
|
||||
procedure SemiCheck;
|
||||
procedure SwitchCheck(aForward: Boolean = True);
|
||||
procedure MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
TKMRadioGroupItem = record
|
||||
Text: UnicodeString;
|
||||
Hint: UnicodeString;
|
||||
Enabled: Boolean;
|
||||
Visible: Boolean;
|
||||
end;
|
||||
|
||||
|
||||
{ TKMRadioGroup }
|
||||
TKMRadioGroup = class(TKMControl)
|
||||
private
|
||||
fItemIndex: Integer;
|
||||
fCount: Integer;
|
||||
fItems: array of TKMRadioGroupItem;
|
||||
fFont: TKMFont;
|
||||
fMouseOverItem: SmallInt;
|
||||
fOnChange: TNotifyEvent;
|
||||
procedure UpdateMouseOverPositions(X,Y: Integer);
|
||||
function GetItem(aIndex: Integer): TKMRadioGroupItem;
|
||||
function GetItemIndexByRow(aRowIndex: Integer): Integer;
|
||||
function GetVisibleCount: Integer;
|
||||
function GetLineHeight: Single;
|
||||
function GetIsSelected: Boolean;
|
||||
protected
|
||||
function GetHint: UnicodeString; override;
|
||||
public
|
||||
AllowUncheck: Boolean; //Do we allow to uncheck selected element ? Usually not, but its possible
|
||||
DrawChkboxOutline: Boolean;
|
||||
LineColor: TColor4; //color of outline
|
||||
LineWidth: Byte;
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aFont: TKMFont);
|
||||
|
||||
procedure Add(const aText: String; aEnabled: Boolean = True); overload;
|
||||
procedure Add(const aText: String; aEnabled, aVisible: Boolean); overload;
|
||||
procedure Add(const aText, aHint: String; aEnabled: Boolean = True; aVisible: Boolean = True); overload;
|
||||
procedure Clear;
|
||||
property Count: Integer read fCount;
|
||||
property IsSelected: Boolean read GetIsSelected;
|
||||
property VisibleCount: Integer read GetVisibleCount;
|
||||
property ItemIndex: Integer read fItemIndex write fItemIndex;
|
||||
property OnChange: TNotifyEvent read fOnChange write fOnChange;
|
||||
property Item[aIndex: Integer]: TKMRadioGroupItem read GetItem;
|
||||
procedure SetItemEnabled(aIndex: Integer; aEnabled: Boolean; aUncheckDisabled: Boolean = True);
|
||||
procedure SetItemVisible(aIndex: Integer; aEnabled: Boolean);
|
||||
procedure CheckFirstCheckable;
|
||||
property LineHeight: Single read GetLineHeight;
|
||||
procedure MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
procedure MouseMove(X,Y: Integer; Shift: TShiftState); override;
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
SysUtils, Math,
|
||||
KM_RenderUI,
|
||||
KM_Resource,
|
||||
KM_Defaults;
|
||||
|
||||
|
||||
{ TKMCheckBox }
|
||||
constructor TKMCheckBox.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; const aCaption: UnicodeString;
|
||||
aFont: TKMFont; aHasSemiState: Boolean = False);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
fFont := aFont;
|
||||
fCaption := aCaption;
|
||||
fHasSemiState := aHasSemiState;
|
||||
LineWidth := 1;
|
||||
LineColor := clChkboxOutline;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCheckBox.SetChecked(aChecked: Boolean);
|
||||
begin
|
||||
if aChecked then
|
||||
fState := cbsChecked
|
||||
else
|
||||
fState := cbsUnchecked;
|
||||
end;
|
||||
|
||||
|
||||
function TKMCheckBox.GetCheckedBool: Boolean;
|
||||
begin
|
||||
Result := fState = cbsChecked;
|
||||
end;
|
||||
|
||||
|
||||
function TKMCheckBox.IsSemiChecked: Boolean;
|
||||
begin
|
||||
Result := fState = cbsSemiChecked;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCheckBox.Check;
|
||||
begin
|
||||
fState := cbsChecked;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCheckBox.SemiCheck;
|
||||
begin
|
||||
fState := cbsSemiChecked;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCheckBox.Uncheck;
|
||||
begin
|
||||
fState := cbsUnchecked;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCheckBox.SwitchCheck(aForward: Boolean = True);
|
||||
begin
|
||||
if fHasSemiState then
|
||||
fState := TKMCheckBoxState((Byte(fState) + 3 + 2*Byte(aForward) - 1) mod 3)
|
||||
else
|
||||
begin
|
||||
if Checked then
|
||||
Uncheck
|
||||
else
|
||||
Check;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCheckBox.MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
if (csDown in State) and (Button = mbLeft) then
|
||||
case fState of
|
||||
cbsSemiChecked,
|
||||
cbsUnchecked: Check; //Let's assume we prefer check for now
|
||||
cbsChecked: Uncheck;
|
||||
end;
|
||||
inherited; //There are OnMouseUp and OnClick events there
|
||||
end;
|
||||
|
||||
|
||||
//We can replace it with something better later on. For now [x] fits just fine
|
||||
//Might need additional graphics to be added to gui.rx
|
||||
//Some kind of box with an outline, darkened background and shadow maybe, similar to other controls.
|
||||
procedure TKMCheckBox.Paint;
|
||||
var
|
||||
col, semiCol: TColor4;
|
||||
checkSize: Integer;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if Enabled then
|
||||
begin
|
||||
col := icWhite;
|
||||
semiCol := $FFCCCCCC;
|
||||
end
|
||||
else
|
||||
begin
|
||||
col := icGray2;
|
||||
semiCol := $FF888888;
|
||||
end;
|
||||
|
||||
checkSize := gRes.Fonts[fFont].GetTextSize('x').Y + 1;
|
||||
|
||||
|
||||
|
||||
TKMRenderUI.WriteBevel(AbsLeft, AbsTop, checkSize - 4, checkSize-4, 1, Byte(not IsSemiChecked and Enabled)*0.35);
|
||||
|
||||
if DrawOutline then
|
||||
TKMRenderUI.WriteOutline(AbsLeft, AbsTop, checkSize - 4, checkSize - 4, LineWidth, LineColor);
|
||||
|
||||
case fState of
|
||||
cbsChecked: TKMRenderUI.WriteText(AbsLeft + (checkSize-4) div 2, AbsTop - 1, 0, 'x', fFont, taCenter, col);
|
||||
cbsSemiChecked: TKMRenderUI.WriteText(AbsLeft + (checkSize-4) div 2, AbsTop - 1, 0, 'x', fFont, taCenter, semiCol);
|
||||
cbsUnchecked: ; //Do not draw anything
|
||||
end;
|
||||
|
||||
|
||||
TKMRenderUI.WriteText(AbsLeft + checkSize, AbsTop, Width - checkSize, fCaption, fFont, taLeft, col);
|
||||
end;
|
||||
|
||||
|
||||
{ TKMRadioGroup }
|
||||
constructor TKMRadioGroup.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aFont: TKMFont);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
fFont := aFont;
|
||||
fItemIndex := -1;
|
||||
LineWidth := 1;
|
||||
LineColor := clChkboxOutline;
|
||||
AllowUncheck := False;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMRadioGroup.Add(const aText: String; aEnabled: Boolean);
|
||||
begin
|
||||
Add(aText, '', aEnabled);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMRadioGroup.Add(const aText: String; aEnabled, aVisible: Boolean);
|
||||
begin
|
||||
Add(aText, '', aEnabled, aVisible);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMRadioGroup.Add(const aText, aHint: String; aEnabled: Boolean = True; aVisible: Boolean = True);
|
||||
begin
|
||||
if fCount >= Length(fItems) then
|
||||
SetLength(fItems, fCount + 8);
|
||||
|
||||
fItems[fCount].Text := aText;
|
||||
fItems[fCount].Hint := aHint;
|
||||
fItems[fCount].Enabled := aEnabled;
|
||||
fItems[fCount].Visible := aVisible;
|
||||
|
||||
Inc(fCount);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMRadioGroup.Clear;
|
||||
begin
|
||||
fCount := 0;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMRadioGroup.MouseUp(X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
var
|
||||
changed: Boolean;
|
||||
begin
|
||||
if (csDown in State) and (Button = mbLeft) then
|
||||
begin
|
||||
UpdateMouseOverPositions(X,Y);
|
||||
if (fMouseOverItem <> -1) and fItems[fMouseOverItem].Enabled then
|
||||
begin
|
||||
changed := False;
|
||||
if (fMouseOverItem = fItemIndex) then
|
||||
begin
|
||||
if AllowUncheck then
|
||||
begin
|
||||
fItemIndex := -1; //Uncheck
|
||||
changed := True;
|
||||
end;
|
||||
end else begin
|
||||
fItemIndex := fMouseOverItem;
|
||||
changed := True;
|
||||
end;
|
||||
|
||||
if changed and Assigned(fOnChange) then
|
||||
begin
|
||||
fOnChange(Self);
|
||||
Exit; //Don't generate OnClick after OnChanged event (esp. when reloading Game on local change)
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
inherited; //There are OnMouseUp and OnClick events there
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMRadioGroup.MouseMove(X,Y: Integer; Shift: TShiftState);
|
||||
begin
|
||||
inherited;
|
||||
UpdateMouseOverPositions(X,Y);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMRadioGroup.UpdateMouseOverPositions(X,Y: Integer);
|
||||
var
|
||||
mouseOverRow, itemIndex: Integer;
|
||||
begin
|
||||
fMouseOverItem := -1;
|
||||
|
||||
if InRange(Y, AbsTop, AbsTop + Height) and (LineHeight > 0) then
|
||||
begin
|
||||
mouseOverRow := EnsureRange((Y - AbsTop) div Round(LineHeight), 0, VisibleCount - 1);
|
||||
itemIndex := GetItemIndexByRow(mouseOverRow);
|
||||
if (itemIndex <> -1) and InRange(X, AbsLeft, AbsLeft + LineHeight + gRes.Fonts[fFont].GetTextSize(fItems[itemIndex].Text).X) then
|
||||
fMouseOverItem := itemIndex;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMRadioGroup.GetItem(aIndex: Integer): TKMRadioGroupItem;
|
||||
begin
|
||||
Assert(aIndex < fCount, 'Can''t get radio group item for index ' + IntToStr(aIndex));
|
||||
Result := fItems[aIndex];
|
||||
end;
|
||||
|
||||
|
||||
function TKMRadioGroup.GetItemIndexByRow(aRowIndex: Integer): Integer;
|
||||
var
|
||||
I, K: Integer;
|
||||
begin
|
||||
Assert(aRowIndex < VisibleCount, 'GetItemByRow: aRowIndex >= VisibleCount');
|
||||
K := 0;
|
||||
Result := -1;
|
||||
for I := 0 to fCount - 1 do
|
||||
begin
|
||||
if not fItems[I].Visible then Continue;
|
||||
if aRowIndex = K then
|
||||
begin
|
||||
Result := I;
|
||||
Exit;
|
||||
end;
|
||||
Inc(K);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMRadioGroup.GetVisibleCount: Integer;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
for I := 0 to fCount - 1 do
|
||||
if fItems[I].Visible then
|
||||
Inc(Result);
|
||||
end;
|
||||
|
||||
|
||||
function TKMRadioGroup.GetLineHeight: Single;
|
||||
begin
|
||||
Result := IfThen(VisibleCount > 0, Height / VisibleCount, Height);
|
||||
end;
|
||||
|
||||
|
||||
function TKMRadioGroup.GetIsSelected: Boolean;
|
||||
begin
|
||||
Result := fItemIndex <> -1;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMRadioGroup.SetItemEnabled(aIndex: Integer; aEnabled: Boolean; aUncheckDisabled: Boolean = True);
|
||||
begin
|
||||
Assert(aIndex < fCount, 'Can''t SetItemEnabled for index ' + IntToStr(aIndex));
|
||||
fItems[aIndex].Enabled := aEnabled;
|
||||
|
||||
// Reset item index, if this item was selected
|
||||
if aUncheckDisabled and not aEnabled and (fItemIndex = aIndex) then
|
||||
fItemIndex := -1;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMRadioGroup.SetItemVisible(aIndex: Integer; aEnabled: Boolean);
|
||||
begin
|
||||
Assert(aIndex < fCount, 'Can''t SetItemVisible for index ' + IntToStr(aIndex));
|
||||
fItems[aIndex].Visible := aEnabled;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMRadioGroup.CheckFirstCheckable;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
if fItemIndex <> -1 then Exit;
|
||||
|
||||
for I := 0 to fCount - 1 do
|
||||
if fItems[I].Enabled and fItems[I].Visible then
|
||||
begin
|
||||
fItemIndex := I;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMRadioGroup.GetHint: UnicodeString;
|
||||
begin
|
||||
Result := inherited GetHint;
|
||||
if Result = '' then
|
||||
begin
|
||||
if fMouseOverItem <> -1 then
|
||||
Result := fItems[fMouseOverItem].Hint;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
//We can replace it with something better later on. For now [x] fits just fine
|
||||
//Might need additional graphics to be added to gui.rx
|
||||
//Some kind of box with an outline, darkened background and shadow maybe, similar to other controls.
|
||||
procedure TKMRadioGroup.Paint;
|
||||
const
|
||||
FONT_COL: array [Boolean] of TColor4 = ($FF888888, $FFFFFFFF);
|
||||
var
|
||||
CheckSize: Integer;
|
||||
I, VisibleI: Integer;
|
||||
begin
|
||||
inherited;
|
||||
if (Count = 0) or (VisibleCount = 0) then Exit; //Avoid dividing by zero
|
||||
|
||||
CheckSize := gRes.Fonts[fFont].GetTextSize('x').Y + 1;
|
||||
|
||||
VisibleI := 0;
|
||||
for I := 0 to Count - 1 do
|
||||
begin
|
||||
if not fItems[I].Visible then
|
||||
Continue;
|
||||
|
||||
TKMRenderUI.WriteBevel(AbsLeft, AbsTop + Round(VisibleI * LineHeight), CheckSize-4, CheckSize-4, 1, 0.3);
|
||||
if DrawChkboxOutline then
|
||||
TKMRenderUI.WriteOutline(AbsLeft, AbsTop + Round(VisibleI * LineHeight), CheckSize-4, CheckSize-4, LineWidth, LineColor);
|
||||
|
||||
if fItemIndex = I then
|
||||
TKMRenderUI.WriteText(AbsLeft + (CheckSize - 4) div 2, AbsTop + Round(VisibleI * LineHeight) - 1, 0,
|
||||
'x', fFont, taCenter, FONT_COL[Enabled and fItems[I].Enabled]);
|
||||
|
||||
// Caption
|
||||
TKMRenderUI.WriteText(AbsLeft + CheckSize, AbsTop + Round(VisibleI * LineHeight), Width - Round(LineHeight),
|
||||
fItems[I].Text, fFont, taLeft, FONT_COL[Enabled and fItems[I].Enabled]);
|
||||
Inc(VisibleI);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
@@ -0,0 +1,266 @@
|
||||
unit KM_ControlsTrackBar;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, Controls,
|
||||
KM_Controls,
|
||||
KM_ResFonts,
|
||||
KM_Points;
|
||||
|
||||
type
|
||||
TKMTrackBar = class(TKMControl)
|
||||
private
|
||||
fTrackTop: Byte; //Offset trackbar from top (if Caption <> '')
|
||||
fTrackHeight: Byte; //Trackbar height
|
||||
fMinValue: Word;
|
||||
fMaxValue: Word;
|
||||
fOnChange: TNotifyEvent;
|
||||
fCaption: UnicodeString;
|
||||
fPosition: Word;
|
||||
fFont: TKMFont;
|
||||
fRange: TKMRangeInt;
|
||||
fThumbText: UnicodeString;
|
||||
fAutoThumbWidth: Boolean;
|
||||
fFixedThumbWidth: Boolean;
|
||||
procedure SetCaption(const aValue: UnicodeString);
|
||||
procedure SetPosition(aValue: Word);
|
||||
procedure SetRange(const aRange: TKMRangeInt);
|
||||
procedure UpdateThumbWidth;
|
||||
procedure SetThumbText(const Value: UnicodeString);
|
||||
procedure SetAutoThumbWidth(const aValue: Boolean);
|
||||
protected
|
||||
function DoHandleMouseWheelByDefault: Boolean; override;
|
||||
public
|
||||
Step: Byte; //Change Position by this amount each time
|
||||
ThumbWidth: Word;
|
||||
CaptionWidth: Integer;
|
||||
SliderFont: TKMFont;
|
||||
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth: Integer; aMin, aMax: Word);
|
||||
|
||||
property Caption: UnicodeString read fCaption write SetCaption;
|
||||
property Position: Word read fPosition write SetPosition;
|
||||
property Range: TKMRangeInt read fRange write SetRange;
|
||||
property Font: TKMFont read fFont write fFont;
|
||||
property MinValue: Word read fMinValue;
|
||||
property MaxValue: Word read fMaxValue;
|
||||
property ThumbText: UnicodeString read fThumbText write SetThumbText;
|
||||
property AutoThumbWidth: Boolean read fAutoThumbWidth write SetAutoThumbWidth;
|
||||
property FixedThumbWidth: Boolean read fAutoThumbWidth write fFixedThumbWidth;
|
||||
procedure ResetRange;
|
||||
property OnChange: TNotifyEvent read fOnChange write fOnChange;
|
||||
procedure MouseDown(X,Y: Integer; Shift: TShiftState; Button: TMouseButton); override;
|
||||
procedure MouseMove(X,Y: Integer; Shift: TShiftState); override;
|
||||
procedure MouseWheel(Sender: TObject; WheelSteps: Integer; var aHandled: Boolean); override;
|
||||
procedure Paint; override;
|
||||
const
|
||||
THUMB_WIDTH_ADD = 24;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
SysUtils, Math,
|
||||
KromUtils, KromOGLUtils,
|
||||
KM_RenderUI,
|
||||
KM_Resource, KM_ResTypes;
|
||||
|
||||
|
||||
{ TKMTrackBar }
|
||||
constructor TKMTrackBar.Create(aParent: TKMPanel; aLeft, aTop, aWidth: Integer; aMin, aMax: Word);
|
||||
begin
|
||||
inherited Create(aParent, aLeft,aTop,aWidth,0);
|
||||
Assert(aMax > aMin, 'TKMTrackBar''s minValue >= maxValue');
|
||||
fMinValue := aMin;
|
||||
fMaxValue := aMax;
|
||||
fTrackHeight := 20;
|
||||
fRange := KMRange(aMin, aMax); //set Range before position
|
||||
Position := (fMinValue + fMaxValue) div 2;
|
||||
Caption := '';
|
||||
Font := fntMetal;
|
||||
SliderFont := fntMetal;
|
||||
CaptionWidth := -1;
|
||||
|
||||
Step := 1;
|
||||
fAutoThumbWidth := False;
|
||||
fFixedThumbWidth := False;
|
||||
|
||||
UpdateThumbWidth;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMTrackBar.UpdateThumbWidth;
|
||||
begin
|
||||
if fFixedThumbWidth then Exit;
|
||||
|
||||
if AutoThumbWidth then
|
||||
ThumbWidth := Max(gRes.Fonts[SliderFont].GetTextSize(IntToStr(MaxValue)).X,
|
||||
gRes.Fonts[SliderFont].GetTextSize(ThumbText).X)
|
||||
else
|
||||
ThumbWidth := gRes.Fonts[SliderFont].GetTextSize(IntToStr(MaxValue)).X;
|
||||
|
||||
ThumbWidth := ThumbWidth + THUMB_WIDTH_ADD;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMTrackBar.SetAutoThumbWidth(const aValue: Boolean);
|
||||
begin
|
||||
fAutoThumbWidth := aValue;
|
||||
UpdateThumbWidth;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMTrackBar.SetCaption(const aValue: UnicodeString);
|
||||
begin
|
||||
fCaption := aValue;
|
||||
|
||||
if Trim(fCaption) <> '' then
|
||||
begin
|
||||
SetHeightSilently(20 + fTrackHeight);
|
||||
fTrackTop := 20;
|
||||
end
|
||||
else
|
||||
begin
|
||||
SetHeightSilently(fTrackHeight);
|
||||
fTrackTop := 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMTrackBar.SetPosition(aValue: Word);
|
||||
begin
|
||||
fPosition := KMEnsureRange(aValue, Range);
|
||||
ThumbText := IntToStr(fPosition);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMTrackBar.SetRange(const aRange: TKMRangeInt);
|
||||
begin
|
||||
fRange.Min := EnsureRange(aRange.Min, MinValue, MaxValue);
|
||||
fRange.Max := EnsureRange(aRange.Max, MinValue, MaxValue);
|
||||
Position := fPosition; //Update position due to range change
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMTrackBar.SetThumbText(const Value: UnicodeString);
|
||||
begin
|
||||
fThumbText := Value;
|
||||
UpdateThumbWidth;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMTrackBar.ResetRange;
|
||||
begin
|
||||
fRange.Min := MinValue;
|
||||
fRange.Max := MaxValue;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMTrackBar.MouseDown(X,Y: Integer; Shift: TShiftState; Button: TMouseButton);
|
||||
begin
|
||||
inherited;
|
||||
MouseMove(X, Y, Shift);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMTrackBar.MouseMove(X,Y: Integer; Shift: TShiftState);
|
||||
var
|
||||
newPos: Integer;
|
||||
posX, stepX: Single;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
newPos := Position;
|
||||
if (ssLeft in Shift)
|
||||
and InRange(Y - AbsTop - fTrackTop, 0, fTrackHeight) then
|
||||
begin
|
||||
posX := 0;
|
||||
if AutoThumbWidth then
|
||||
begin
|
||||
stepX := (Width - ThumbWidth) / (fMaxValue - fMinValue) / Step; // width between marks
|
||||
posX := stepX * (Position / Step) + (ThumbWidth div 2); // actual marks positions on track
|
||||
end;
|
||||
if not AutoThumbWidth
|
||||
or not InRange(X - AbsLeft, posX - ThumbWidth div 2, posX + ThumbWidth div 2) then // do not update pos, if we hover over thumb
|
||||
newPos := EnsureRange(fMinValue + Round(((X-AbsLeft-ThumbWidth div 2) / (Width - ThumbWidth - 4))*(fMaxValue - fMinValue)/Step)*Step, fMinValue, fMaxValue);
|
||||
end;
|
||||
|
||||
if newPos <> Position then
|
||||
begin
|
||||
Position := newPos;
|
||||
|
||||
if Assigned(fOnChange) then
|
||||
fOnChange(Self);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function TKMTrackBar.DoHandleMouseWheelByDefault: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMTrackBar.MouseWheel(Sender: TObject; WheelSteps: Integer; var aHandled: Boolean);
|
||||
var
|
||||
newPos: Integer;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if aHandled or (WheelSteps = 0) then Exit;
|
||||
|
||||
aHandled := WheelSteps <> 0;
|
||||
|
||||
Focus;
|
||||
|
||||
newPos := Position;
|
||||
|
||||
if WheelSteps <> 0 then
|
||||
newPos := EnsureRange(newPos - Step*fMouseWheelStep*WheelSteps, fMinValue, fMaxValue);
|
||||
|
||||
if newPos <> Position then
|
||||
begin
|
||||
Position := newPos;
|
||||
|
||||
if Assigned(fOnChange) then
|
||||
fOnChange(Self);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMTrackBar.Paint;
|
||||
const
|
||||
TEXT_COLOR: array [Boolean] of TColor4 = ($FF888888, $FFFFFFFF);
|
||||
var
|
||||
thumbPos, thumbHeight, rangeMinPos, rangeMaxPos: Word;
|
||||
capWidth: Integer;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if fCaption <> '' then
|
||||
begin
|
||||
if CaptionWidth = -1 then
|
||||
capWidth := Width
|
||||
else
|
||||
capWidth := CaptionWidth;
|
||||
|
||||
TKMRenderUI.WriteText(AbsLeft, AbsTop, capWidth, fCaption, fFont, taLeft, TEXT_COLOR[Enabled]);
|
||||
end;
|
||||
|
||||
rangeMinPos := Round(Width*(fRange.Min-fMinValue) / (fMaxValue - fMinValue));
|
||||
rangeMaxPos := Round(Width*(fRange.Max-fMinValue) / (fMaxValue - fMinValue));
|
||||
|
||||
TKMRenderUI.WriteBevel(AbsLeft, AbsTop+fTrackTop+1, rangeMinPos, fTrackHeight-2, 0, 0.3);
|
||||
TKMRenderUI.WriteBevel(AbsLeft + rangeMinPos, AbsTop+fTrackTop+2, rangeMaxPos - rangeMinPos, fTrackHeight-4);
|
||||
TKMRenderUI.WriteBevel(AbsLeft + rangeMaxPos, AbsTop+fTrackTop+1, Width - rangeMaxPos, fTrackHeight-2, 0, 0.3);
|
||||
|
||||
thumbPos := Round(Mix (0, Width - ThumbWidth, 1-(Position-fMinValue) / (fMaxValue - fMinValue)));
|
||||
thumbHeight := gRes.Sprites[rxGui].RXData.Size[132].Y;
|
||||
|
||||
TKMRenderUI.WritePicture(AbsLeft + thumbPos, AbsTop+fTrackTop, ThumbWidth, thumbHeight, [anLeft,anRight], rxGui, 132);
|
||||
TKMRenderUI.WriteText(AbsLeft + thumbPos + ThumbWidth div 2, AbsTop+fTrackTop+3, 0, ThumbText, SliderFont, taCenter, TEXT_COLOR[Enabled]);
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
@@ -0,0 +1,23 @@
|
||||
unit KM_ControlsTypes;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
|
||||
|
||||
type
|
||||
TKMAllowedChars = (
|
||||
acDigits, // Only 0..9 digits, for numeric input
|
||||
acHex, // Only 0..9 A..F a..f, for input hex values (colors)
|
||||
acANSI7, // #33..#123,#125,#126 - only basic latin chars and symbols for user nickname, except |
|
||||
acFileName, // Exclude symbols that can't be used in filenames
|
||||
acText, // Anything is allowed except for eol symbol
|
||||
acAll // Anything is allowed
|
||||
);
|
||||
|
||||
const
|
||||
CTRL_HIGHLIGHT_COEF_DEF = 0.4;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,62 @@
|
||||
unit KM_ControlsUtils;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes,
|
||||
KM_ControlsTypes,
|
||||
KM_CommonTypes;
|
||||
|
||||
|
||||
// Check if specified aChar is allowed for specified aAllowedChars type
|
||||
function IsCharAllowed(aChar: WideChar; aAllowedChars: TKMAllowedChars): Boolean;
|
||||
|
||||
function IsSelecting(Key: Word; Shift: TShiftState): Boolean;
|
||||
|
||||
function GetCursorDir(aKey: Word): TKMCursorDir;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
{$IFDEF MSWindows} Windows, {$ENDIF}
|
||||
{$IFDEF Unix} LCLIntf, LCLType, {$ENDIF}
|
||||
Math,
|
||||
KromUtils;
|
||||
|
||||
|
||||
// Check if specified aChar is allowed for specified aAllowedChars type
|
||||
function IsCharAllowed(aChar: WideChar; aAllowedChars: TKMAllowedChars): Boolean;
|
||||
const
|
||||
HEX_DIGITS: TSetOfAnsiChar = [#48..#57, #65..#70, #97..#102]; // 0..9 A..F a..f
|
||||
ANSI7_CHARS: TSetOfAnsiChar = [#32..#123, #125..#126]; // except | character
|
||||
NON_FILE_CHARS: TSetOfAnsiChar = [#0 .. #31, '<', '>', #176, '|', '"', '\', '/', ':', '*', '?'];
|
||||
NON_TEXT_CHARS_WEOL: TSetOfAnsiChar = [#0 .. #31, #176, '|']; // ° has negative width so acts like a backspace in KaM fonts
|
||||
NON_TEXT_CHARS: TSetOfAnsiChar = [#0 .. #31, #176]; // ° has negative width so acts like a backspace in KaM fonts
|
||||
begin
|
||||
Result := not ((aAllowedChars = acDigits) and not InRange(Ord(aChar), 48, 57)
|
||||
or (aAllowedChars = acHex) and not CharInSet(aChar, HEX_DIGITS)
|
||||
or (aAllowedChars = acANSI7) and not CharInSet(aChar, ANSI7_CHARS)
|
||||
or (aAllowedChars = acFileName) and CharInSet(aChar, NON_FILE_CHARS)
|
||||
or (aAllowedChars = acText) and CharInSet(aChar, NON_TEXT_CHARS_WEOL)
|
||||
or (aAllowedChars = acAll) and CharInSet(aChar, NON_TEXT_CHARS));
|
||||
end;
|
||||
|
||||
|
||||
function IsSelecting(Key: Word; Shift: TShiftState): Boolean;
|
||||
begin
|
||||
Result := (ssShift in Shift) and (Key <> VK_SHIFT);
|
||||
end;
|
||||
|
||||
|
||||
function GetCursorDir(aKey: Word): TKMCursorDir;
|
||||
begin
|
||||
case aKey of
|
||||
VK_LEFT: Result := cdBack;
|
||||
VK_RIGHT: Result := cdForward;
|
||||
else
|
||||
Result := cdNone;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
@@ -0,0 +1,309 @@
|
||||
unit KM_ControlsWaresRow;
|
||||
{$I KaM_Remake.inc}
|
||||
interface
|
||||
uses
|
||||
Classes, Controls,
|
||||
KM_Controls, KM_ControlsBase,
|
||||
KM_ResTypes,
|
||||
KM_CommonTypes, KM_Defaults;
|
||||
|
||||
|
||||
type
|
||||
// Row with resource name and icons
|
||||
TKMWaresRow = class(TKMButtonFlatCommon)
|
||||
public
|
||||
WareCount: Word;
|
||||
WareCntAsNumber: Boolean;
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth: Integer); overload;
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth: Integer; aClickable: Boolean); overload;
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
// Ware order bar
|
||||
TKMWareOrderRow = class(TKMControl)
|
||||
private
|
||||
fWaresRow: TKMWaresRow;
|
||||
fOrderAdd: TKMButton;
|
||||
fOrderLab: TKMLabel;
|
||||
fOrderRem: TKMButton;
|
||||
fOrderCount: Integer;
|
||||
fImmediateOrder: Boolean; // Order count can be changed immediately in control. Always set False because of MP delay
|
||||
procedure ButtonClick(Sender: TObject; Shift: TShiftState);
|
||||
procedure ClickHold(Sender: TObject; Button: TMouseButton; var aHandled: Boolean);
|
||||
procedure SetOrderRemHint(const aValue: UnicodeString);
|
||||
procedure SetOrderAddHint(const aValue: UnicodeString);
|
||||
procedure SetOrderCount(aValue: Integer);
|
||||
protected
|
||||
procedure SetTop(aValue: Integer); override;
|
||||
procedure SetEnabled(aValue: Boolean); override;
|
||||
procedure SetVisible(aValue: Boolean); override;
|
||||
function DoHandleMouseWheelByDefault: Boolean; override;
|
||||
public
|
||||
OrderCntMax: Integer;
|
||||
OnChange: TKMNotifyEventInteger;
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth: Integer; aOrderCntMax: Integer = MAX_WARES_IN_HOUSE);
|
||||
property WareRow: TKMWaresRow read fWaresRow;
|
||||
property OrderCount: Integer read fOrderCount write SetOrderCount;
|
||||
property OrderRemHint: UnicodeString write SetOrderRemHint;
|
||||
property OrderAddHint: UnicodeString write SetOrderAddHint;
|
||||
procedure MouseWheel(Sender: TObject; WheelSteps: Integer; var aHandled: Boolean); override;
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
// Production cost bar
|
||||
TKMCostsRow = class(TKMControl)
|
||||
public
|
||||
RX: TRXType;
|
||||
TexID1, TexID2: Word;
|
||||
Count: Byte;
|
||||
Caption: UnicodeString;
|
||||
MaxCount: Byte;
|
||||
constructor Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aMaxCount: Byte = 6);
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
{$IFDEF MSWindows} Windows, {$ENDIF}
|
||||
{$IFDEF Unix} LCLIntf, LCLType, {$ENDIF}
|
||||
SysUtils, Math,
|
||||
KM_RenderUI,
|
||||
KM_ResFonts,
|
||||
KM_UtilsExt;
|
||||
|
||||
const
|
||||
WARE_ROW_HEIGHT = 21;
|
||||
|
||||
|
||||
{ TKMWaresRow }
|
||||
constructor TKMWaresRow.Create(aParent: TKMPanel; aLeft, aTop, aWidth: Integer);
|
||||
begin
|
||||
Create(aParent, aLeft, aTop, aWidth, False);
|
||||
end;
|
||||
|
||||
|
||||
constructor TKMWaresRow.Create(aParent: TKMPanel; aLeft, aTop, aWidth: Integer; aClickable: Boolean);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, WARE_ROW_HEIGHT, 0);
|
||||
Clickable := aClickable;
|
||||
HideHighlight := not aClickable;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMWaresRow.Paint;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
inherited;
|
||||
TKMRenderUI.WriteText(AbsLeft + 4, AbsTop + 3, Width-8, Caption, fntGame, taLeft, $FFE0E0E0);
|
||||
//Render in reverse order so the rightmost resource is on top (otherwise lighting looks wrong)
|
||||
if WareCntAsNumber then
|
||||
begin
|
||||
TKMRenderUI.WriteText(AbsLeft + Width - 18 - 70 + 24, AbsTop + 3, 40, IntToStr(WareCount), fntGame, taRight, $FFE0E0E0);
|
||||
TKMRenderUI.WritePicture(AbsLeft + Width - 18, AbsTop + 3, 14, 14, [], RX, TexID);
|
||||
end else
|
||||
for I := WareCount - 1 downto 0 do
|
||||
TKMRenderUI.WritePicture(AbsLeft + Width - 18 - I * 14, AbsTop + 3, 14, 14, [], RX, TexID);
|
||||
end;
|
||||
|
||||
|
||||
{ TKMWareOrderRow }
|
||||
constructor TKMWareOrderRow.Create(aParent: TKMPanel; aLeft, aTop, aWidth: Integer; aOrderCntMax: Integer = MAX_WARES_IN_HOUSE);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, WARE_ROW_HEIGHT);
|
||||
|
||||
fWaresRow := TKMWaresRow.Create(aParent, aLeft + 68, aTop, aWidth - 68);
|
||||
|
||||
fImmediateOrder := False;
|
||||
|
||||
OrderCntMax := aOrderCntMax;
|
||||
|
||||
fOrderRem := TKMButton.Create(aParent, aLeft, 0, 20, Height - 2, '-', bsGame);
|
||||
fOrderAdd := TKMButton.Create(aParent, aLeft + 46, 0, 20, Height - 2, '+', bsGame);
|
||||
//Label after buttons, to be sure it will be on top of them, to let player read value from it, if too long (more then 3 symbols)
|
||||
fOrderLab := TKMLabel.Create (aParent, aLeft + 33, 0, '', fntGrey, taCenter);
|
||||
|
||||
fOrderAdd.CapOffsetY := 1;
|
||||
|
||||
fOrderRem.OnClickShift := ButtonClick;
|
||||
fOrderAdd.OnClickShift := ButtonClick;
|
||||
fOrderRem.OnMouseWheel := MouseWheel;
|
||||
fOrderAdd.OnMouseWheel := MouseWheel;
|
||||
fWaresRow.OnMouseWheel := MouseWheel;
|
||||
fOrderRem.OnClickHold := ClickHold;
|
||||
fOrderAdd.OnClickHold := ClickHold;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMWareOrderRow.ButtonClick(Sender: TObject; Shift: TShiftState);
|
||||
var
|
||||
amt: Integer;
|
||||
begin
|
||||
amt := GetMultiplicator(Shift);
|
||||
if Sender = fOrderRem then
|
||||
amt := -amt;
|
||||
|
||||
if amt = 0 then Exit;
|
||||
|
||||
if fImmediateOrder then
|
||||
OrderCount := fOrderCount + amt;
|
||||
|
||||
Focus;
|
||||
|
||||
if Assigned(OnChange) then
|
||||
OnChange(Self, amt);
|
||||
end;
|
||||
|
||||
|
||||
function TKMWareOrderRow.DoHandleMouseWheelByDefault: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMWareOrderRow.MouseWheel(Sender: TObject; WheelSteps: Integer; var aHandled: Boolean);
|
||||
var
|
||||
amt: Integer;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if aHandled then Exit;
|
||||
|
||||
amt := MouseWheelStep * WheelSteps;
|
||||
if GetKeyState(VK_SHIFT) < 0 then
|
||||
amt := amt * 10;
|
||||
|
||||
if fImmediateOrder then
|
||||
OrderCount := fOrderCount + amt;
|
||||
|
||||
aHandled := amt <> 0;
|
||||
|
||||
Focus;
|
||||
|
||||
if Assigned(OnChange) then
|
||||
OnChange(Self, amt);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMWareOrderRow.ClickHold(Sender: TObject; Button: TMouseButton; var aHandled: Boolean);
|
||||
var
|
||||
amt: Integer;
|
||||
begin
|
||||
inherited;
|
||||
aHandled := True;
|
||||
|
||||
amt := GetMultiplicator(Button);
|
||||
|
||||
if Sender = fOrderRem then
|
||||
amt := -amt;
|
||||
|
||||
if amt = 0 then Exit;
|
||||
|
||||
if fImmediateOrder then
|
||||
OrderCount := fOrderCount + amt;
|
||||
|
||||
if Assigned(OnChange) then
|
||||
OnChange(Self, amt);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMWareOrderRow.SetOrderCount(aValue: Integer);
|
||||
begin
|
||||
fOrderCount := EnsureRange(aValue, 0, OrderCntMax);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMWareOrderRow.SetOrderRemHint(const aValue: UnicodeString);
|
||||
begin
|
||||
fOrderRem.Hint := aValue;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMWareOrderRow.SetOrderAddHint(const aValue: UnicodeString);
|
||||
begin
|
||||
fOrderAdd.Hint := aValue;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMWareOrderRow.SetTop(aValue: Integer);
|
||||
begin
|
||||
inherited;
|
||||
fWaresRow.Top := aValue;
|
||||
end;
|
||||
|
||||
|
||||
//Copy property to buttons
|
||||
procedure TKMWareOrderRow.SetEnabled(aValue: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
fWaresRow.Enabled := Enabled;
|
||||
fOrderRem.Enabled := Enabled;
|
||||
fOrderLab.Enabled := Enabled;
|
||||
fOrderAdd.Enabled := Enabled;
|
||||
end;
|
||||
|
||||
|
||||
//Copy property to buttons. Otherwise they won't be rendered
|
||||
procedure TKMWareOrderRow.SetVisible(aValue: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
fWaresRow.Visible := IsSetVisible;
|
||||
fOrderRem.Visible := IsSetVisible;
|
||||
fOrderLab.Visible := IsSetVisible;
|
||||
fOrderAdd.Visible := IsSetVisible;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMWareOrderRow.Paint;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
fOrderRem.Top := Top + 1; //Use internal fTop instead of GetTop (which will return absolute value)
|
||||
fOrderLab.Top := Top + 4;
|
||||
fOrderAdd.Top := Top + 1;
|
||||
|
||||
fOrderLab.Caption := IntToKStr(OrderCount, 1000);
|
||||
end;
|
||||
|
||||
|
||||
{ TKMCostsRow }
|
||||
constructor TKMCostsRow.Create(aParent: TKMPanel; aLeft, aTop, aWidth, aHeight: Integer; aMaxCount: Byte = 6);
|
||||
begin
|
||||
inherited Create(aParent, aLeft, aTop, aWidth, aHeight);
|
||||
|
||||
MaxCount := aMaxCount;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKMCostsRow.Paint;
|
||||
var
|
||||
I, gap: Integer;
|
||||
begin
|
||||
inherited;
|
||||
TKMRenderUI.WriteText(AbsLeft, AbsTop + 4, Width-20, Caption, fntGrey, taLeft, $FFFFFFFF);
|
||||
|
||||
if Count > 0 then
|
||||
begin
|
||||
if Count <= MaxCount then
|
||||
gap := 20
|
||||
else
|
||||
gap := Trunc(MaxCount * 20 / Count);
|
||||
|
||||
if TexID1 <> 0 then
|
||||
for I := Count - 1 downto 0 do
|
||||
TKMRenderUI.WritePicture(AbsLeft+Width-gap*(I+1), AbsTop, 20, Height, [], RX, TexID1);
|
||||
end else
|
||||
begin
|
||||
if TexID1 <> 0 then
|
||||
TKMRenderUI.WritePicture(AbsLeft+Width-40, AbsTop, 20, Height, [], RX, TexID1);
|
||||
if TexID2 <> 0 then
|
||||
TKMRenderUI.WritePicture(AbsLeft+Width-20, AbsTop, 20, Height, [], RX, TexID2);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
||||
File diff suppressed because it is too large.
Load diff
+1463
File diff suppressed because it is too large.
Load diff
File diff suppressed because it is too large.
Load diff
+527
@@ -0,0 +1,527 @@
|
||||
// SPDX-License-Identifier: LGPL-3.0-linking-exception
|
||||
unit BGRAArrow;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, BGRABitmapTypes, BGRAGraphics;
|
||||
|
||||
type
|
||||
{ TBGRAArrow }
|
||||
|
||||
TBGRAArrow = class(TBGRACustomArrow)
|
||||
private
|
||||
FLineCap: TPenEndCap;
|
||||
FWidth : single;
|
||||
FStart : ArrayOfTPointF;
|
||||
FStartComputed: boolean;
|
||||
FStartStyle: TBGRAArrowStyle;
|
||||
FStartSizeFactor: TPointF;
|
||||
FStartTipStyle: TPenJoinStyle;
|
||||
FStartOffsetX: single;
|
||||
FStartRepeatCount: integer;
|
||||
FStartRelativePenWidth: single;
|
||||
FStartTriangleBackOffset: single;
|
||||
FEnd : ArrayOfTPointF;
|
||||
FEndComputed: boolean;
|
||||
FEndStyle: TBGRAArrowStyle;
|
||||
FEndSizeFactor: TPointF;
|
||||
FEndTipStyle: TPenJoinStyle;
|
||||
FEndOffsetX: single;
|
||||
FEndRepeatCount: integer;
|
||||
FEndRelativePenWidth: single;
|
||||
FEndTriangleBackOffset: single;
|
||||
function ComputeAnyAt(const AData: ArrayOfTPointF; const APosition, ADirection: TPointF): ArrayOfTPointF;
|
||||
function ComputeData(AStyle: TBGRAArrowStyle; const ASizeFactor: TPointF;
|
||||
ATipStyle: TPenJoinStyle; ALineCap: TPenEndCap; const AWidth: single; AOffsetX: single;
|
||||
ARepeatCount: integer; ARelativePenWidth: single; ATriangleBackOffset: single): ArrayOfTPointF;
|
||||
procedure SetWidth(AValue: single);
|
||||
protected
|
||||
function GetEndRepeatCount: integer; override;
|
||||
function GetEndSizeFactor: TPointF; override;
|
||||
function GetIsEndDefined: boolean; override;
|
||||
function GetIsStartDefined: boolean; override;
|
||||
function GetEndOffsetX: single; override;
|
||||
function GetStartOffsetX: single; override;
|
||||
function GetStartRepeatCount: integer; override;
|
||||
function GetStartSizeFactor: TPointF; override;
|
||||
procedure SetEndOffsetX(AValue: single); override;
|
||||
procedure SetEndRepeatCount(AValue: integer); override;
|
||||
procedure SetEndSizeFactor(AValue: TPointF); override;
|
||||
procedure SetStartOffsetX(AValue: single); override;
|
||||
procedure SetStartRepeatCount(AValue: integer); override;
|
||||
procedure SetStartSizeFactor(AValue: TPointF); override;
|
||||
function GetLineCap: TPenEndCap; override;
|
||||
procedure SetLineCap(AValue: TPenEndCap); override;
|
||||
procedure SetStart(AStyle: TBGRAArrowStyle; ATipStyle: TPenJoinStyle = pjsMiter; ARelativePenWidth: single = 1; ATriangleBackOffset: single = 0);
|
||||
procedure SetEnd(AStyle: TBGRAArrowStyle; ATipStyle: TPenJoinStyle = pjsMiter; ARelativePenWidth: single = 1; ATriangleBackOffset: single = 0);
|
||||
public
|
||||
constructor Create;
|
||||
procedure StartAsNone; override;
|
||||
procedure StartAsClassic(AFlipped: boolean = false; ACut: boolean = false; ARelativePenWidth: single = 1); override;
|
||||
procedure StartAsTriangle(ABackOffset: single = 0; ARounded: boolean = false; AHollow: boolean = false; AHollowPenWidth: single = 0.5); override;
|
||||
procedure StartAsTail; override;
|
||||
procedure EndAsNone; override;
|
||||
procedure EndAsClassic(AFlipped: boolean = false; ACut: boolean = false; ARelativePenWidth: single = 1); override;
|
||||
procedure EndAsTriangle(ABackOffset: single = 0; ARounded: boolean = false; AHollow: boolean = false; AHollowPenWidth: single = 0.5); override;
|
||||
procedure EndAsTail; override;
|
||||
function ComputeStartAt(const APosition: TPointF; const ADirection: TPointF; const AWidth: single; const ACurrentPos: single): ArrayOfTPointF; override;
|
||||
function ComputeEndAt(const APosition: TPointF; const ADirection: TPointF; const AWidth: single; const ACurrentPos: single): ArrayOfTPointF; override;
|
||||
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses BGRAClasses, BGRATransform, BGRAPen, BGRAPath;
|
||||
|
||||
{ TBGRAArrow }
|
||||
|
||||
function TBGRAArrow.ComputeAnyAt(const AData: ArrayOfTPointF; const APosition,
|
||||
ADirection: TPointF): ArrayOfTPointF;
|
||||
var m: TAffineMatrix;
|
||||
i: integer;
|
||||
begin
|
||||
if (AData = nil) or isEmptyPointF(APosition) or isEmptyPointF(ADirection) or ((ADirection.x = 0) and (ADirection.y = 0)) then
|
||||
begin
|
||||
result := nil;
|
||||
exit;
|
||||
end;
|
||||
m := AffineMatrixTranslation(APosition.x,APosition.y)*AffineMatrixLinear(ADirection, PointF(-ADirection.y, ADirection.x));
|
||||
setlength(result, length(AData));
|
||||
for i := 0 to high(result) do
|
||||
if not isEmptyPointF(AData[i]) then
|
||||
result[i] := m*AData[i]
|
||||
else
|
||||
result[i] := EmptyPointF;
|
||||
end;
|
||||
|
||||
function TBGRAArrow.ComputeData(AStyle: TBGRAArrowStyle;
|
||||
const ASizeFactor: TPointF; ATipStyle: TPenJoinStyle; ALineCap: TPenEndCap;
|
||||
const AWidth: single; AOffsetX: single; ARepeatCount: integer;
|
||||
ARelativePenWidth: single; ATriangleBackOffset: single): ArrayOfTPointF;
|
||||
var sizeFactorX,sizeFactorY,ofsX: single;
|
||||
prefix,suffix,middle: ArrayOfTPointF;
|
||||
arc: TArcDef;
|
||||
i,j,n : integer;
|
||||
withCut: ArrayOfTPointF;
|
||||
subResult: ArrayOfTPointF;
|
||||
w: single;
|
||||
backOfs: single;
|
||||
tailSizeX, tailAdditionalWidth: single;
|
||||
begin
|
||||
sizeFactorX := abs(ASizeFactor.X)*AWidth;
|
||||
sizeFactorY := abs(ASizeFactor.Y)*AWidth;
|
||||
if (sizeFactorX = 0) or (sizeFactorY = 0) then
|
||||
begin
|
||||
result := nil;
|
||||
exit;
|
||||
end;
|
||||
w := AWidth*ARelativePenWidth;
|
||||
if AStyle in [asTail,asTailRepeat] then
|
||||
begin
|
||||
tailSizeX := sizeFactorX/SizeFactorY*AWidth*0.5;
|
||||
if AStyle = asTailRepeat then
|
||||
begin
|
||||
tailAdditionalWidth:= AWidth-tailSizeX;
|
||||
if tailAdditionalWidth < 0 then tailAdditionalWidth := 0;
|
||||
end else
|
||||
tailAdditionalWidth:=0;
|
||||
end
|
||||
else
|
||||
begin
|
||||
tailSizeX := 0;
|
||||
tailAdditionalWidth:=0;
|
||||
end;
|
||||
case AStyle of
|
||||
asTriangle,asHollowTriangle: begin
|
||||
backOfs := ATriangleBackOffset*sizeFactorX;
|
||||
if AStyle = asHollowTriangle then
|
||||
begin
|
||||
result := ComputeWidePolylinePoints(PointsF([PointF(0.5*w,-AWidth*0.5),
|
||||
PointF(0.5*w-backOfs,-sizeFactorY+w*0.5),
|
||||
PointF(sizeFactorX-w*0.5,0),
|
||||
PointF(w*0.5-backOfs,sizeFactorY-w*0.5),
|
||||
PointF(0.5*w,AWidth*0.5)]),
|
||||
w,BGRABlack,ALineCap,ATipStyle,nil,[plCycle]);
|
||||
end else
|
||||
begin
|
||||
prefix := PointsF([PointF(0,-AWidth*0.5),PointF(-backOfs,-sizeFactorY)]);
|
||||
suffix := PointsF([PointF(-backOfs,sizeFactorY),PointF(0,AWidth*0.5)]);
|
||||
if (ATipStyle in[pjsRound,pjsBevel]) then
|
||||
begin
|
||||
arc := Html5ArcTo(prefix[1],PointF(sizeFactorX,0),suffix[0],AWidth*0.5);
|
||||
if ATipStyle = pjsRound then
|
||||
middle := ComputeArc(arc)
|
||||
else
|
||||
middle := PointsF([ArcStartPoint(arc),ArcEndPoint(arc)]);
|
||||
end
|
||||
else middle := PointsF([PointF(sizeFactorX,0)]);
|
||||
result := ConcatPointsF([prefix,middle,suffix]);
|
||||
end;
|
||||
end;
|
||||
asNormal,asCut:
|
||||
begin
|
||||
if AStyle = asCut then ALineCap:= pecSquare;
|
||||
result := ComputeWidePolylinePoints([PointF(-sizeFactorX,-sizeFactorY),
|
||||
PointF(0,0),PointF(-sizeFactorX,+sizeFactorY)],w,BGRABlack,ALineCap,ATipStyle,nil,[]);
|
||||
end;
|
||||
asFlipped,asFlippedCut:
|
||||
begin
|
||||
if AStyle = asFlippedCut then ALineCap:= pecSquare;
|
||||
result := ComputeWidePolylinePoints([PointF(+sizeFactorX,-sizeFactorY),
|
||||
PointF(0,0),PointF(+sizeFactorX,+sizeFactorY)],w,BGRABlack,ALineCap,ATipStyle,nil,[]);
|
||||
end;
|
||||
asTail: result := PointsF([PointF(0,-0.5*AWidth),PointF(tailSizeX,-0.5*AWidth),PointF(0,0),PointF(tailSizeX,0.5*AWidth),PointF(0,0.5*AWidth)]);
|
||||
asTailRepeat: result := PointsF([PointF(0,-0.5*AWidth),PointF(tailSizeX+tailAdditionalWidth,-0.5*AWidth),PointF(tailAdditionalWidth,0),PointF(tailSizeX+tailAdditionalWidth,0.5*AWidth),PointF(0,0.5*AWidth),PointF(-tailSizeX,0)]);
|
||||
else
|
||||
result := nil;
|
||||
end;
|
||||
if (AStyle in [asCut,asFlippedCut,asHollowTriangle]) then
|
||||
begin
|
||||
n := 0;
|
||||
setlength(withCut,length(result)*2);
|
||||
for i := 0 to high(result) do
|
||||
if isEmptyPointF(result[i]) then
|
||||
begin
|
||||
if (n > 0) and not isEmptyPointF(withCut[n-1]) then
|
||||
begin
|
||||
withCut[n] := EmptyPointF;
|
||||
inc(n);
|
||||
end;
|
||||
end else
|
||||
if abs(result[i].y)<=sizeFactorY then
|
||||
begin
|
||||
withCut[n] := result[i];
|
||||
inc(n);
|
||||
end else
|
||||
if result[i].y>sizeFactorY then
|
||||
begin
|
||||
j := (i+length(result)-1) mod length(result);
|
||||
if result[j].y<=sizeFactorY then
|
||||
begin
|
||||
withCut[n].x := result[j].x + (result[i].x-result[j].x)/(result[i].y-result[j].y)*(sizeFactorY-result[j].y);
|
||||
withCut[n].y := sizeFactorY;
|
||||
inc(n);
|
||||
end;
|
||||
j := (i+1) mod length(result);
|
||||
if result[j].y<=sizeFactorY then
|
||||
begin
|
||||
withCut[n].x := result[j].x + (result[i].x-result[j].x)/(result[i].y-result[j].y)*(sizeFactorY-result[j].y);
|
||||
withCut[n].y := sizeFactorY;
|
||||
inc(n);
|
||||
end;
|
||||
end else
|
||||
if result[i].y<-sizeFactorY then
|
||||
begin
|
||||
j := (i+length(result)-1) mod length(result);
|
||||
if result[j].y>=-sizeFactorY then
|
||||
begin
|
||||
withCut[n].x := result[j].x + (result[i].x-result[j].x)/(result[i].y-result[j].y)*(-sizeFactorY-result[j].y);
|
||||
withCut[n].y := -sizeFactorY;
|
||||
inc(n);
|
||||
end;
|
||||
j := (i+1) mod length(result);
|
||||
if result[j].y>=-sizeFactorY then
|
||||
begin
|
||||
withCut[n].x := result[j].x + (result[i].x-result[j].x)/(result[i].y-result[j].y)*(-sizeFactorY-result[j].y);
|
||||
withCut[n].y := -sizeFactorY;
|
||||
inc(n);
|
||||
end;
|
||||
end;
|
||||
if (n > 0) and isEmptyPointF(withCut[n-1]) then dec(n);
|
||||
setlength(withCut,n);
|
||||
result := withCut;
|
||||
end;
|
||||
if AOffsetX <> 0 then
|
||||
begin
|
||||
ofsX := AOffsetX*AWidth;
|
||||
for i := 0 to high(result) do
|
||||
if not isEmptyPointF(result[i]) then
|
||||
IncF(result[i].x, ofsX);
|
||||
end;
|
||||
if ARepeatCount > 1 then
|
||||
begin
|
||||
if ARepeatCount > 10 then ARepeatCount:= 10;
|
||||
if AStyle in[asTriangle,asHollowTriangle] then IncF(AOffsetX, sizeFactorX/AWidth)
|
||||
else if AStyle in[asTail,asTailRepeat] then IncF(AOffsetX, (tailSizeX+tailAdditionalWidth)/AWidth+1)
|
||||
else IncF(AOffsetX, 2*ARelativePenWidth);
|
||||
if AStyle = asTail then AStyle := asTailRepeat;
|
||||
subResult := ComputeData(AStyle,ASizeFactor,ATipStyle,ALineCap,AWidth,AOffsetX,ARepeatCount-1,ARelativePenWidth,ATriangleBackOffset);
|
||||
result := ConcatPointsF([result,PointsF([EmptyPointF]),subResult]);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TBGRAArrow.GetIsEndDefined: boolean;
|
||||
begin
|
||||
result := FEndStyle <> asNone;
|
||||
end;
|
||||
|
||||
function TBGRAArrow.GetIsStartDefined: boolean;
|
||||
begin
|
||||
result := FStartStyle <> asNone;
|
||||
end;
|
||||
|
||||
function TBGRAArrow.GetEndOffsetX: single;
|
||||
begin
|
||||
result := FEndOffsetX;
|
||||
end;
|
||||
|
||||
function TBGRAArrow.GetStartOffsetX: single;
|
||||
begin
|
||||
result := FStartOffsetX;
|
||||
end;
|
||||
|
||||
function TBGRAArrow.GetStartRepeatCount: integer;
|
||||
begin
|
||||
result := FStartRepeatCount;
|
||||
end;
|
||||
|
||||
function TBGRAArrow.GetStartSizeFactor: TPointF;
|
||||
begin
|
||||
result := FStartSizeFactor;
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.SetEndOffsetX(AValue: single);
|
||||
begin
|
||||
if FEndOffsetX=AValue then Exit;
|
||||
FEndOffsetX:=AValue;
|
||||
FEndComputed:= false;
|
||||
FEnd := nil;
|
||||
end;
|
||||
|
||||
function TBGRAArrow.GetLineCap: TPenEndCap;
|
||||
begin
|
||||
result := FLineCap;
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.SetEndRepeatCount(AValue: integer);
|
||||
begin
|
||||
if FEndRepeatCount=AValue then Exit;
|
||||
FEndRepeatCount:=AValue;
|
||||
FEndComputed:= false;
|
||||
FEnd := nil;
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.SetEndSizeFactor(AValue: TPointF);
|
||||
begin
|
||||
if FEndSizeFactor=AValue then Exit;
|
||||
FEndSizeFactor:=AValue;
|
||||
FEndComputed:= false;
|
||||
FEnd := nil;
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.SetLineCap(AValue: TPenEndCap);
|
||||
begin
|
||||
if FLineCap=AValue then Exit;
|
||||
FLineCap:=AValue;
|
||||
FStartComputed:= false;
|
||||
FEndComputed:= false;
|
||||
FStart:= nil;
|
||||
FEnd := nil;
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.SetStartOffsetX(AValue: single);
|
||||
begin
|
||||
if FStartOffsetX=AValue then Exit;
|
||||
FStartOffsetX:=AValue;
|
||||
FStartComputed:= false;
|
||||
FStart := nil;
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.SetStartRepeatCount(AValue: integer);
|
||||
begin
|
||||
if FStartRepeatCount=AValue then Exit;
|
||||
FStartRepeatCount:=AValue;
|
||||
FStartComputed:= false;
|
||||
FStart := nil;
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.SetStartSizeFactor(AValue: TPointF);
|
||||
begin
|
||||
if FStartSizeFactor=AValue then Exit;
|
||||
FStartSizeFactor:=AValue;
|
||||
FStartComputed:= false;
|
||||
FStart := nil;
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.SetWidth(AValue: single);
|
||||
begin
|
||||
if FWidth=AValue then Exit;
|
||||
FWidth:=AValue;
|
||||
FStartComputed := false;
|
||||
FEndComputed:= false;
|
||||
end;
|
||||
|
||||
function TBGRAArrow.GetEndRepeatCount: integer;
|
||||
begin
|
||||
Result:= FEndRepeatCount;
|
||||
end;
|
||||
|
||||
function TBGRAArrow.GetEndSizeFactor: TPointF;
|
||||
begin
|
||||
Result:= FEndSizeFactor;
|
||||
end;
|
||||
|
||||
constructor TBGRAArrow.Create;
|
||||
begin
|
||||
FWidth := 1;
|
||||
FStartSizeFactor := PointF(2,2);
|
||||
FEndSizeFactor := PointF(2,2);
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.StartAsNone;
|
||||
begin
|
||||
SetStart(asNone);
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.StartAsClassic(AFlipped: boolean; ACut: boolean;
|
||||
ARelativePenWidth: single);
|
||||
var join: TPenJoinStyle;
|
||||
begin
|
||||
if (LineCap = pecRound) and not ACut then join := pjsRound else join := pjsMiter;
|
||||
if ACut then
|
||||
begin
|
||||
if AFlipped then
|
||||
SetStart(asFlippedCut,join,ARelativePenWidth)
|
||||
else
|
||||
SetStart(asCut,join,ARelativePenWidth)
|
||||
end
|
||||
else
|
||||
begin
|
||||
if AFlipped then
|
||||
SetStart(asFlipped,join,ARelativePenWidth)
|
||||
else
|
||||
SetStart(asNormal,join,ARelativePenWidth)
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.StartAsTriangle(ABackOffset: single; ARounded: boolean;
|
||||
AHollow: boolean; AHollowPenWidth: single);
|
||||
var join: TPenJoinStyle;
|
||||
begin
|
||||
if ARounded then join := pjsRound else join := pjsMiter;
|
||||
if AHollow then
|
||||
SetStart(asHollowTriangle, join,AHollowPenWidth, ABackOffset)
|
||||
else
|
||||
SetStart(asTriangle, join,1,ABackOffset);
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.StartAsTail;
|
||||
begin
|
||||
SetStart(asTail);
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.EndAsNone;
|
||||
begin
|
||||
SetEnd(asNone);
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.EndAsClassic(AFlipped: boolean; ACut: boolean;
|
||||
ARelativePenWidth: single);
|
||||
var join: TPenJoinStyle;
|
||||
begin
|
||||
if (LineCap = pecRound) and not ACut then join := pjsRound else join := pjsMiter;
|
||||
if ACut then
|
||||
begin
|
||||
if AFlipped then
|
||||
SetEnd(asFlippedCut,join,ARelativePenWidth)
|
||||
else
|
||||
SetEnd(asCut,join,ARelativePenWidth)
|
||||
end
|
||||
else
|
||||
begin
|
||||
if AFlipped then
|
||||
SetEnd(asFlipped,join,ARelativePenWidth)
|
||||
else
|
||||
SetEnd(asNormal,join,ARelativePenWidth)
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.EndAsTriangle(ABackOffset: single; ARounded: boolean;
|
||||
AHollow: boolean; AHollowPenWidth: single);
|
||||
var join: TPenJoinStyle;
|
||||
begin
|
||||
if ARounded then join := pjsRound else join := pjsMiter;
|
||||
if AHollow then
|
||||
SetEnd(asHollowTriangle, join,AHollowPenWidth, ABackOffset)
|
||||
else
|
||||
SetEnd(asTriangle, join,1, ABackOffset);
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.EndAsTail;
|
||||
begin
|
||||
SetEnd(asTail);
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.SetStart(AStyle: TBGRAArrowStyle;
|
||||
ATipStyle: TPenJoinStyle; ARelativePenWidth: single; ATriangleBackOffset: single);
|
||||
begin
|
||||
FStartStyle := AStyle;
|
||||
FStartTipStyle := ATipStyle;
|
||||
FStartComputed := false;
|
||||
FStartRelativePenWidth:= ARelativePenWidth;
|
||||
FStartTriangleBackOffset := ATriangleBackOffset;
|
||||
FStart := nil;
|
||||
end;
|
||||
|
||||
procedure TBGRAArrow.SetEnd(AStyle: TBGRAArrowStyle; ATipStyle: TPenJoinStyle;
|
||||
ARelativePenWidth: single; ATriangleBackOffset: single);
|
||||
begin
|
||||
FEndStyle := AStyle;
|
||||
FEndTipStyle := ATipStyle;
|
||||
FEndComputed := false;
|
||||
FEndRelativePenWidth:= ARelativePenWidth;
|
||||
FEndTriangleBackOffset := ATriangleBackOffset;
|
||||
FEnd := nil;
|
||||
end;
|
||||
|
||||
function TBGRAArrow.ComputeStartAt(const APosition: TPointF;
|
||||
const ADirection: TPointF; const AWidth: single; const ACurrentPos: single
|
||||
): ArrayOfTPointF;
|
||||
begin
|
||||
if not IsStartDefined then
|
||||
begin
|
||||
result := nil;
|
||||
exit;
|
||||
end;
|
||||
if AWidth <> FWidth then
|
||||
begin
|
||||
FWidth := AWidth;
|
||||
FStartComputed:= false;
|
||||
end;
|
||||
if not FStartComputed then
|
||||
begin
|
||||
FStart := ComputeData(FStartStyle,FStartSizeFactor,FStartTipStyle,FLineCap,FWidth,
|
||||
FStartOffsetX-ACurrentPos,FStartRepeatCount,FStartRelativePenWidth,FStartTriangleBackOffset);
|
||||
FStartComputed:= true;
|
||||
end;
|
||||
result := ComputeAnyAt(FStart,APosition,ADirection);
|
||||
end;
|
||||
|
||||
function TBGRAArrow.ComputeEndAt(const APosition: TPointF;
|
||||
const ADirection: TPointF; const AWidth: single; const ACurrentPos: single
|
||||
): ArrayOfTPointF;
|
||||
begin
|
||||
if not IsEndDefined then
|
||||
begin
|
||||
result := nil;
|
||||
exit;
|
||||
end;
|
||||
if AWidth <> FWidth then
|
||||
begin
|
||||
FWidth := AWidth;
|
||||
FEndComputed:= false;
|
||||
end;
|
||||
if not FEndComputed then
|
||||
begin
|
||||
FEnd := ComputeData(FEndStyle,FEndSizeFactor,FEndTipStyle,FLineCap,FWidth,
|
||||
FEndOffsetX-ACurrentPos,FEndRepeatCount,FEndRelativePenWidth,FEndTriangleBackOffset);
|
||||
FEndComputed:= true;
|
||||
end;
|
||||
result := ComputeAnyAt(FEnd,APosition,ADirection);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
Loaded 100 of 993 files, more files were not shown because too many files have changed in this diff.
Show more
Reference in new issue
Block a user