Topológiai játékok Ördög Rafael
1
CÉLKITŰZÉSEK
3
JONES POLINOMOK ÉS KAUFFMAN ZÁRÓJELEK IMMERTÁLT FELÜLETEK MINIMÁLIS SZÁMÚ HÁROMSZOROS PONTTAL A LIPPNER ALGORITMUS
3 3 3
A SZOFTVEREKRŐL
4
JONES POLINOMOK ÉS KAUFFMAN ZÁRÓJELEK HASZNÁLATA MŰKÖDÉSI ELV IMMERTÁLT FELÜLETEK MINIMÁLIS SZÁMÚ HÁROMSZOROS PONTTAL HASZNÁLATA MŰKÖDÉSI ELV FELÜLET KONSTRUÁLÁS A LIPPNER ALGORITMUS HASZNÁLATA ELDÖNTŐ ALGORITMUS MŰKÖDÉSI ELVE A KONSTRUKCIÓ ELŐÁLLÍTÁSA
4 4 5 6 6 7 8 10 10 12 12
NÉHÁNY A PROGRAM ÁLTAL GENERÁLT FELÜLET
17
KÓD: 0,0,0,1,2,2 KÓD: 0,0,0,1,4,0 KÓD: 0,0,1,2,1,2,7,7,7,1,8
17 19 20
ÉRDEKESSÉGEK
22
ÉSZREVÉTELEK
29
A NULL HOMOTÓP GÖRBÉK ESETE EGY NAGYON SPECIÁLIS ESET
29 31
FÜGGELÉK - FORRÁS KÓDOK
33
JONES POLINOMOK ÉS KAUFFMAN ZÁRÓJELEK IMMERTÁLT FELÜLETEK MINIMÁLIS SZÁMÚ HÁROMSZOROS PONTTAL FORM1.FRM FORM2.FRM FRMOPERATION.FRM CALCTAU.BAS DIJKSTRA.BAS GLOBALS.BAS TRIANGULATEMODULE2.BAS BUTAREND.CLS CURVES.CLS LIPPNER ALGORITMUS FORM1.FRM FORM2.FRM
33 38 38 45 50 51 52 53 54 62 63 65 65 80
2
Célkitűzések Habár napjainkra már a matematika legtöbb területén bevetették a számítógépeket, a topológia területén egyenlőre nem nagyon akad ilyen jellegű kísérlet. Elsődleges célunk, néhány már ismert – de gyakorlatban nem alkalmazott – topológia tárgykörében felmerülő algoritmus programozása, illetve azok alkalmazása azzal a szándékkal, hogy – főleg kísérletek segítségével – jobban megértsük az adott témakört, illetve oktatásban alkalmazható szemléltető ábrákat készítsünk.
Jones Polinomok és Kauffman zárójelek A megvalósításra került algoritmus kiszámolja egy adott csomó/lánc Jones polinomját, illetve Kauffman zárójelét. Ez esetben maga az algoritmus egyszerűen megvalósítható volt, de lépésszáma exponenciális, ami alkalmazhatóságának komoly korlátokat szab. Ezen korlátok szabta határok között néhány nevezetesebb láncra összefoglaljuk az eredményeket. Miután Action Scriptben fejlesztettük az alkalmazást, ezért Interneten is közzé tehető.
Immertált felületek minimális számú háromszoros ponttal Csikós B. és Szûcs A. „On the number of triple points of an immersed surface with boundary” című cikkében található t kiszámítását valósítjuk meg. (Legyen adott egy síkba immertált görbe, és jelölje tg az F immerzió háromszoros pontjainak számának minimumát, ahol F egy lyukas g-génuszu felület olyan immerziója, mely a peremen az előre adott görbe immerziójával egyezik meg. A t ezen tg értékek minimuma.) Az eredeti cikk megkonstruálja a minimális értékhez tartozó egyik immerziót is. Ezt a konstrukciót ugyan (idő hiányában) nem implementáltuk, de az algoritmust pontosítottuk a könnyebb programozhatóság érdekében. Így hosszú távon, akár Vizualizáló programokba is exportálható modell előállítására is módot lehet teremteni. (Sőt e a konstruáló algoritmus részben el is készült, és működési elvét is tárgyaljuk.)
A Lippner algoritmus Lippner G. által „On double points of immersions of spheres” című cikkében olyan algoritmust ír le, amely egymást nem metsző, párba állított gömbi körvonalak rendszeréről megállapítja, hogy előállhat-e mint egy gömb háromszoros pont mentes öntranszverzális immerziójának a kettőspont halmaza, és meg is konstruálja az immerziót, ha létezik. Ennek során az olyan immerziókat is vizsgálja, melyek körök mentén érintik önmagukat. A végleges program mindkét kérdésre választ ad, és a megkonstruált felületet OBJ formátumban exportálja, így az betölthető vizualizáló vagy CAD rendszerekbe. Választ adunk arra a kérdésre, hogy független-e egymástól a transzverzális, és az érintő eset. A válasz igen: létezik olyan eset, mikor mindkettő megvalósítható/nem megvalósítható, illetve olyan is, amikor pontosan az egyik valósítható meg, továbbá nem következik egyikből sem a másik. Megadjuk a minimális példákat is mind a négy esetben. Osztályozzuk a legfeljebb 6 körből álló rendszereket, és megadjuk, hogy melyek valósíthatóak meg. Az általánosítás reményében modelleket készítettünk a tóruszra vonatkozó megfelelő kérdésre, továbbá néhány egyszerű észrevételt is teszünk.
3
A szoftverekről Ebben a fejezetben mutatjuk be az alkalmazások működését.
Jones Polinomok és Kauffman zárójelek Ez az alkalmazás Flash dokumentum formájában jött létre. Interneten publikált változatának futtatásához Flash plug-in-el rendelkező böngésző szükséges, de önállóan futtatható alkalmazásként is elérhető
Használata A mellékelt ábrán 3 jól elkülöníthető részt találunk. A bal-felső négyzethálós rajzoló mezőt, a jobb felső menüt, valamint az alul található válasz mezőt. A menü további 3 részre bomlik, felülről lefele rajz eszközök, lekérdező gombok, és példa gombok. Az egyetlen rajzeszköz, ami nem görbedarab a bal felső sarokban található piros nyíl végű körív. A rajz mező szolgál a csomók megrajzolására. Minden egyes négyzetben a rajzeszközöknél felsorolt 11 darab görbe darab egyikét helyezhetjük el, ezen görbe darabokból áll majd össze a teljes görbe. Minden görbe komponensben meg fog jelenni egy olyan kör ív, melyen egy piros nyíl található, mely a görbe irányítását hivatott jelezni. Ez a nyíl fordítható meg a balfelső sarokban található rajzeszközzel. A menü első gombjával (Reset) törölhetjük a rajz mezőt. A következő három gomb ellenőrzést szolgál, sorban: • Check – valóban záródik-e minden görbe. A válasz mezőben „false” jelenik meg ha nem, és „true” ha igen. • No.Comps. – a válasz mezőben megjeleníti a görbe komponensek számát. • Sign sum – a kettős pontokhoz rendelt előjelek összege. Definíciót lásd.: Kauffman: State models and the Jones polynomial-ban Ez után következnek azok a menüpontok, melyekkel lekérdezhetjük a számunkra igazán fontos értékeket. Az eredmény a következő formában jeleni meg a válaszmezőben: an(n)+…+ ai(i)+…+am(m) ahol ai az xi együthatója. • KauffmanB – kiszámolja a Kauffman zárójelet • KauffmanP – kiszámolja a Kauffman zárójelből származtatott polinomot • Jones – kiszámolja a Jones polinomot A példa gombok néhány ismertebb csomót, illetve láncot rajzolnak fel automatikusan. A Braid(n) esetében egy almenübe jutunk, ahol 2-tôl 11-ig adhatjuk meg n értékét. Ezeket , és a hozzájuk tartozó polinomokat foglalja össze a következő táblázat.
4
Menüpont / név Komponens szám Előjelösszeg Kauffman zárójel Kauffman polinom Jones polinom Hopf Link
Ábra
2 -2 -4
-x -x4 -x2-x10 -x1/2-x5/2 Tori (2,3) – Tórikus 2,3 csomó 1 -3 -5
-x -x3+x7 x4+x12-x16 x-1+x-3-x-4 Braid(4) 2 4 6
2
-x -x +x6-x10 -x-18-x-10+x-6-x-2 -x9/2-x5/2+x3/2-x1/2 Braid(5) 1 -5 -7
-x -x+x5-x9+x13 x8+x16-x20+x24-x28 x-2+x-4-x-5+x-6-x-7 Tri Link 3 0 -12
-8
-4
-x +3x -2x +4-2x4+3x8-x12 -x-12+3x-8-2x-4+4-2x4+3x8-x12 -x3+3x2-2x+4-2x-1+3x-2-x-3
5
Működési elv A Jones polinomok kiszámítására Kauffman adott a zárójelek segítségével igen egyszerű algoritmust. Ennek során egy csomódiagramból kiindulva minden kettőspontot lecserélünk két egymást nem metsző ívre. Ezt kétféle képen tehetjük meg, így összesen 2n lehetőség adódik, ahol n a metszés pontok száma, és minden esetben egymást és önmagukat nem metsző görbékhez jutunk. Ezekből indulva számoljuk ki először a zárójelet, és innen adódik az exponenciális lépés szám is. Megjegyzendő, hogy miután Laurent polinomokról van szó, ezért hagyományos módon (azaz nullától indexelt tömbben, az i. helyen tárolva az xi együtthatóját) nem tudjuk megoldani a tárolást. Ezért egy más adat-strukturális megoldást választottunk. Jelölje p[] a polinomot tároló tömböt. Ekkor a polinom a következő képen nyerhető: xp[0] Si>0 p[i]xi További előnye az így kapott adatstruktúrának, hogy x hatvánnyal való szorzás egyetlen lépés (holott általában a polinom fokától függ), és ilyenből sok van az algoritmus során. Ez tehát egy általánosságában is jól használható adatstruktúra lehet, mert az összeadás nem lassul, ami gyorsabb futást eredményez, mint a hagyományos polinom tárolásra szolgáló adatstruktúránál. A Kauffman zárójel számítása ezek után nagyon egyszerűvé válik. Keresünk egy kettőspontot, lecseréljük, majd rekurzíven meghívjuk a függvényt mindkét esetre. Az eredményeknek egy „ferde összegét” kell venni. (A q(x) és p(x) polinomok ferde összegén a következőt értjük: xq(x)+x-1p(x)) Ha nincs kettőspont, akkor a
komponensek száma adja meg a Kauffman zárójel értékét, ilyenkor ez a visszatérési érték.
Immertált felületek minimális számú háromszoros ponttal Használata Az alkalmazás felhasználói felülete egy felül található menüből, és az alatta elhelyezkedő rajzmezőből áll. A menü elemeire később térünk vissza, először térjünk ki a rajz mező használatára. A mellékelt ábrán látható, hogy alapértelmezett beállítás esetén a rajzmezőben a görbe feketével rajzolóik ki. A kékkel jelölt pontok a kontrollpontok, melyek a görbe útját adják meg közelítőleg, az érzékelt metszéspontokat pedig piros karika jelöli. A kontrollpontok közé az alkalmazás további 10 pontot illeszt. (Másodfokú polinom interpoláció segítségével.) Meglévő kontrollpont mozgatásához kattintsunk egérrel a mozgatni kívánt pontra, és húzzuk a megfelelő helyre. Új kontrollpontot úgy hozhatunk létre, ha a görbe megfelelő szakaszára kattintunk, vagy tetszőleges egyéb helyre, ez utóbbi esetben azonban az új pont mindig a legnagyobb sorszámú pont után kerül beszúrásra. Technikai okokból az algoritmus érzékeny a túl közeli metszés pontokra. Ilyenkor a piros
karika, piros ponttá változik, és az ablak alján egy hiba üzenet is megjelenik. Általános érvényű irányelv tehát a görbék megrajzolása során: 1. A kettőspontok lehetőleg minél távolabb legyenek egymástól. (A teljes görbe méretéhez viszonyítva.) 2. Két kontrollpont között lehetőleg egy, vagy maximum két kettős pont legyen. 3. A görbék ránézésre (szubjektíven megítélve) simák legyenek, és általános helyzetűek, a metszés pontok közel merőlegesek. 4. Fontos ellenőrizni, hogy a program minden metszéspontot észlelt. (Előfordulhat számítási hiba.)
6
A menü File menü tartalma: • New, Open, Save, Save As…, Exit – a megszokott módon működnek. • Calculate Tau – Kiszámolja a háromszoros pontok számának minimumát. Az algoritmus lassú, legyünk türelmesek. Az eredmény egy újonnan megnyíló ablakban jelenik meg. (Ha páratlan a metszéspontok száma, akkor -1-et kapunk válaszul.) View menü tartalma • Show Nod IDs – A kontrollpontok sorszámát kiírja/elrejti a rajz mezőben. • Show Derivates – A kontrollpontokban megmutatja/elrejti az érintőket. • Show Intersections – A metszés pontokat mutatja/elrejti • Show All Points – A kontrollpontok közé legenerált további 10-10 pont megjelenítése/rejtése • Show Grid – Igazító rács megjelenítése/rejtése. • Snap To Grid – Kontrollpontok rácshoz való igazítása, illetve pontok szabad mozgatása között vált.
Működési elv Feladatunk módot találni a Csikós - Szűcs cikkben megadott pontpárok, és a görbe hurkolódásának kiszámítására, valamint a hurkolódásokból kiszámítani a t értékét. Ez nem lesz nehéz, ha feltételezzük, hogy már adott a szakaszokra bontott görbét tartalmazó kompakt síkbeli (lehetőleg konvex) tartománynak egy olyan háromszögelése, mely ezen szakaszokat élként tartalmazza. Éppen ezért egyelőre tegyük fel, hogy egy ilyen már adott, és a későbbiekben erre még visszatérünk. Hurkolódás számítása Tekintsük a meglévő háromszögelés duális felbontásának 2-vázát mint gráfot, és ebben a gráfban keressünk egy utat Dijksztra (vagy egyéb más útkereső algoritmussal) és az út mentén adjuk össze a metszési indexeket mindazon út-élekre, melyek duálisai rajta vannak a görbén. Ez éppen a hurkolódás. (A gyakorlatban való megvalósítás részleteiről a háromszögelés megkonstruálásánál ejtünk majd pár szót.) A t értékének számítása Szemeljünk ki egy tetszőleges metszéspontot (mondjuk azt, amelyiket elsőként megtaláltuk) és minden további metszésponttal vet hurkolódását számítsuk ki. Keressük meg a minimális, és maximális kapott értéket, és hozzunk létre egy egész típusú tömböt, aminek legkisebb és legnagyobb indexe az előbb megtalált minimum, és maximum, és kezdetben legyen minden indexre az érték nulla. (Ha a programozási nyelv amit használunk nem ismeri a negatív indexeket – mint például a C++ - akkor természetesen ezt korrigálhatjuk ugyanúgy, ahogy a Laurent polinomok tárolását oldottuk meg.) A vödör rendezéshez hasonlatos dolgot fogunk tenni. Minden egyes pontra növeljük annak a tömbelemnek az értékét eggyel, melynek indexe megegyezik az előző bekezdésben kiszemelt, és a most feldolgozás alatt álló pont hurkolódásával. (A kiszemelt pontra is! Ez a 0 indexhez tartozó tömb elem növelését jelenti.) Végül végigmegyünk a tömbön, és az i. lépésben figyeljük az első i db tömbelem összegét. Ha ez páratlan, akkor növeljük egyel a t értékét. A végén éppen a kívánt minimumot fogjuk kapni. Bizonyítás Az eredeti cikkben megadott definíciók mellet: k
τ ( f ) = ∑ l2i −1, 2i i =1
Ezt átírhatjuk a következő alakra: 7
k
k
k
τ ( f ) = ∑ l2i −1,1 + l1, 2i = ∑ ((−l1, 2i −1 ) + l1, 2i ) = ∑ (l1, 2i − l1, 2i −1 ) i =1
i =1
i =1
Egy-egy tag akkor nem esik ki ha az első ponttal vett hurkolódás nem azonos egy páros indexű, és az őt követő páratlan indexű pontra, azaz l1, 2i −1 és l1, 2i nem egyenlő. Ilyen akkor fordul elő, ha a fenti algoritmus során valamelyik vödörben páratlan sok elemet találunk, és pontosan annyi lesz a különbség, amennyi a következő nem üres vödörtől való távolság. Ezen távolságok összege éppen az a szám, amit akkor kapunk, ha vesszük azon i-k számát melyekre az első i vödörben található elemek száma páratlan. † Megjegyzés A fenti algoritmus nem szűri ki annak lehetőségét, hogy páratlan sok metszés pont van. Ezt külön kell ellenőrizni, például úgy, hogy az összes tömb elem összegének paritását ellenőrizzük. (Párosnak kell lennie.) A háromszögelés módja Feladatunk tehát olyan háromszögelést előállítani, mely élként tartalmazza a görbének megfeleltetett közelítő szakaszokat. Vázlatosan leírva, ezt úgy tesszük meg, hogy először bari-centrikusan felbontunk minden olyan háromszöget, amely tartalmazza valamely szakasz végpontját. (Elfajult esetként felléphet olyan, hogy már eleve csúcs ez a végpont, ilyenkor nem teszünk semmit, illetve olyan is előfordulhat, hogy élen van a csúcspont, ilyenkor az élhez illeszkedő két háromszöget 2-2 további háromszögre bontjuk az éllel szemközti csúcs, és az új pont által meghatározott szakasszal.) Ez után azon élekre, melyek ezen felbontások során nem jöttek létre, felvesszük új pontnak a szomszédos csúcspontok között futó szakasz, és a meglévő élek metszéspontjait, és tovább bontjuk a háromszögelést a fent ismertetett módon ezen pontokkal. Ez egy jó háromszögelést fog adni. Bizonyítás Világos, hogy minden szükséges csúcspontot megtaláltunk, a második lépés során pedig nem hozhattunk létre olyan élt, amely metszené az éppen feldolgozás alatt álló szomszédos pontpárt összekötő szakaszt. (Ha valamelyik metszené, akkor két közös pontja lenne vele – a szakaszt bontó, és a nem kívánt metszéspont – azaz ez a szakasz része a szükséges élnek.) Ennek következtében egy adott – a kérdéses szakasz által átmetszett - eredeti háromszög két metszett oldalán lévő metszés pontok közötti szakaszt nem metszheti át új él, tehát – miután minden lap háromszög – szükségképen van egy összekötő él közöttük. † Fontos megjegyezni, hogy a számítási hibák miatt, érdemes bevezetni egy tűréshatárt, melyen belül azonosnak tekintünk pontokat, így elkerülhetőek a közel elfajult háromszögek, valamint a számítási hibából eredő problémák. Vigyázni kell továbbá arra, hogy két pont közötti élmetszések keresésekor előbb keressünk, és az után adjuk hozzá az új pontokat a háromszögeléshez, különben könnyen végtelen ciklusba szorulhat az algoritmus szintén a számítási hibák következményeképen. Ez azonban azt is jelenti, hogy előfordulhat olyan eset, hogy egy metszéspont egy új háromszögbe kerül át, mire annak feldolgozására sor kerül, tehát ha az éleket a lapokhoz rendelve tároljuk, az ebből adódó index változásokat figyelni kell.
Felület konstruálás Sajnos ennek megvalósítására nem került sor, de az elv teljes mértékben kidolgozásra került. Először minden olyan élet helyettesítünk a görbe síkjára merőleges téglalappal, mely nem csatlakozik kétszeres ponthoz. Minden kettőspont környezetét (hozzá csatlakozó négy élet)
8
helyettesítjük a mellékelt ábrán lévő objektummal. Ez tehát még gyakorlatilag szó szerint megfelel annak, amit a Csikós - Szűcs cikkben konstrukcióként leírnak a szerzők. Az első nehézség ott adódik, amikor két beágyazott, egy felületet közösen határoló görbét, melyeknek irányítása egyszerre indukálható a köztük lévő felület valamelyik irányításából összefüggő uniózni kell. Ekkor ugyanis egy nem feltétlenül konvex tartományon belül kell találnunk egy út párt. Ezt a problémát általánosságában is megfogalmazzuk, mert később is szükségünk lesz rá.
A tetszőleges út probléma Rengetegszer fordul elő topológiában, hogy egy nem konvex téren belül kell tetszőleges utat, vagy csövet választanunk. Ez felületek vizualizálása/modellezése esetén komoly problémát vet fel, hiszen véges algoritmust kell találnunk ezen „tetszőleges választás” konkretizálására. Szerencsére ilyen esetekben adott egy - amúgy kellemetlen, de jelen esetben hasznos – tulajdonsága a számítógépes modellezésnek, nevezetesen az, hogy minden felületet – még a simákat is – szimplexek uniójaként állít elő. A problémára tehát egyszerű megoldást találhatunk, ha a háromszögelést vesszük alapul. A szimplexek érintkezési gráfja (duális felbontás 1-váza) ugyanis egy véges gráf (mellesleg (n+1)-reguláris, ahol n a szimplex dimenziója) melyben alkalmazhatjuk a Dijksztra algoritmust út keresésre. Így viszont a problémát redukáltuk a következőre: 1. Érjük el, hogy a keresendő cső a háromszögelés egyetlen tetraéderébe essen. (Út esetén ez nyílván automatikus.) 2. Oldjuk meg a problémát a tetraéderen belül úgy, hogy az egymás mellé helyezett tetraéderek határán illeszkedjenek a megfelelő objektumok.
Ebben a speciális esetben azonban a fenti algoritmusban beszélhetünk szimplexek helyett speciális esetként háromszögekről. A problémát tehát úgy oldjuk meg, hogy kiválasztjuk mindkét (szakaszokra bontott) görbe egy-egy élét, ezek között keresünk egy gráfelméleti értelemben vett utat a két görbe által közösen határolt felületdarab háromszögelésén belül, majd az út által érintett háromszögeket a következő módon bontjuk fel: a háromszögnek pontosan két élén át halad a gráf elméleti út, ezeket 3 egyenlő részre bontjuk fel, és összekötjük a megfelelő párokat. Az így adódó 2 négyzetlapot tovább bontjuk két háromszöggé. (Ld. az ábrát.) Az ábrán pirossal jelölt újonnan adódó élek lesznek az összekötő útpár élei. Az így kapott útpárnak megfelelő szalag fölé helyezve egy fél-csövet megint szó szerint követjük az eredeti cikkben leírt konstrukciót. Fontos azonban, hogy a felületet úgy építsük,
9
hogy minden egyes összefüggő unió után a kapott új görbesereg fölé emeljünk újabb „szintet”, ezáltal elérjük, hogy a fél-csövek a sík felett különböző magasságban haladjanak, tehát ne metsszék egymást. Ezt követően feladatunk a csokor nyakkendők összekötése, a lehető legkevesebb háromszoros pont létrehozásával. Újra a fenti elvet alkalmazzuk, de ezúttal a Dijksztra algoritmust él-súlyozott gráf esetében alkalmazzuk. A görbékhez tartozó élek súlyának 1-et választjuk a többi él súlya legyen 0. Ekkor a Dijkstra algoritmus meg fogja találni a legkönnyebb utat, ami speciálisan ebben az esetben egy legkevesebb 3-szoros pontot eredményező csokornyakkendő kötés lesz. Utolsó lépésként a megmaradt zárt, önmetszés mentes görbéket kell lezárnunk. Ezt úgy tesszük, hogy a görbén belüli háromszögekkel felülről bezárjuk. Amennyiben egymást tartalmazó görbék is vannak, úgy a legbelső lezárása után a többit egy szinttel tovább emelve haladunk belülről kifele, és így zárjuk le az összes görbét felülről.
A Lippner algoritmus Programozás technikai okokból néhány apró észrevételt érdemes megtenni itt az elején. Miután véges sok sima görbét rajzolnunk a gömb felületre, ezért a gömbből szabad elhagyni egy pontot, és inverzióval így a kérdést a következő ekvivalens kérdésre fogalmazhatjuk át: a sík egy olyan immerzióját keressük, mely egy kompakt halmaztól eltekintve a standard beágyazás, a kompakt részen pedig olyan, hogy pontosan az előre felrajzolt körök mentén érinti / transzverzálisan metszi önmagát. Ekkor a fának is kijelölődik egy természetesen adódó gyökere, mely természetesen függ az inverziótól
Használata Ezt az algoritmust technikai okokból két külön alkalmazásba bontottuk szét. Az alap alkalmazás egy eldöntési problémát old meg, és kiszámol bizonyos adatokat a 3D geometria megkonstruálásához, míg a konstruáló program a kiszámolt adatokból létre hozza a geometriát. Az alapalkalmazás fő ablaka Az ablak áll a menüből (fent), a ábrázoló mezőből (középen) és a válasz mezőből (lent). A View menüben választhatjuk ki, hogy mit szeretnénk megjeleníteni az ábrázoló mezőben. A következő lehetőségek közül választhatunk: • Original Tree – Az eredeti kör rendszer által meghatározott fa. • Double Switch Tree – A Double Switch-ek után kapott fa. • Original circles – Az eredeti körrendszer. (Úgy ahogy exportálni fogja, és nem úgy ahogy eredetileg felrajzoltuk. A tartalmazás relációt megtartja.) • Double Switch – A Double Switchek által előállított kör pár rendszer.
10
A File menü tartalma: • Line Input – Fa adatinak kézi bevitele. (ld.: később) • Graphical Input – Fa előállítása megrajzolt körökből. (ld.: később) • History – Az utolsó 10 fa egyikének újra behívása. • Export Touchdata – Fa adatainak mentése külső program számára. • Export Duplicated Touchdata – Érintéses immerzió modelljének megkonstruálásához szükséges adatok előállítása, és mentése a konstruáló program (vagy más külső program) számára. • Export Transversal Data - Transzverzális immerzió modelljének megkonstruálásához szükséges adatok előállítása, és mentése a konstruáló program (vagy más külső program) számára. Line input használata Legyen a gyökér csúcs indexe 0, és minden további csúcs indexe azonos annak az élnek az indexével, melynek ő alsó végpontja. Minden párosított fához hozzárendelünk egy számsorozatot. Tegyük fel, hogy a fa csúcsai úgy vannak megszámozva, hogy a párok egymást követő értékeket kapnak. (Tehát minden i-re, 2i és 2i+1 adnak meg egy párt.) Adjuk meg minden csúcsra a szülő csúcsot, és írjuk le egymás után a kapott számokat vesszővel ellátva. Az így kapott számsort nevezzük a fa kódjának a továbbiakban. A Line input menüpont választásakor megjelenő beviteli mezőbe ezt a kódot kell beírni. Néhány példa látható a 23. oldalon lévô táblázatban. Graphical input használata Az alábbi ábrán látható párbeszéd panel jelenik meg a Graphical input menüpont választása után. A Clear, és az Ok feliratú gombok alatt található a rajzmező, melyben most a (0,0,2,3,2,1,3,5) párosított fa kódnak megfelelő körrendszer rajza látható. Itt tudjuk megrajzolni a körrendszer köreit az alábbiakban vázolt módon.
A körök közepén, valamint a köríven is található egy-egy kis fekete kör. Ezek jelölik a kontrol pontokat, melyekkel a körök elhelyezését tudjuk módosítani. Drag&Drop módszerrel tudjuk odébb húzni őket. Új kör létrehozásához kattintsunk egy tetszőleges helyre – mely a 11
létrehozandó kör középpontja lesz – majd húzzuk (a gombot nyomva tartva) az egeret olyan távolságra, amilyen sugarú kört szeretnénk létrehozni. Ha a megadott körrendszerben páros sok kör van, és ezek nem metszik egymást, akkor az Ok gomb engedélyezetté válik, és ezt megnyomva a párbeszéd panel eltűnik, és az alkalmazás generálja a körpár rendszerhez tartozó fa kódját. Bármilyen módon is adtuk meg a körrendszert, vagy a hozzá tartozó fát, azonnal megjelenik az alkalmazás fő ablakának alján található válasz mezőben az eredmény. Négy lehetséges válasz van: „TouchRealizable and Realizable”, „NonTouchRealizable and Realizable”, „TouchRealizable and NonRealizable”, „NonTouchRealizable and NonRealizable”. (Értelem szerűen az „and” előtti rész az érintő megvalósíthatóságra vonatkozik míg az utána következő rész a transzverzálisra.) A File menü további három menüpontja adatok külső programba való továbbítására szolgál. Csak abban az esetben működik, ha megvalósítható a körrendszerhez tartozó megfelelő értelemben vett immerzió. Ennek oka, hogy további extra információkat is közöl. Ezen extra információkról a következő részben szólunk részletesebben.
Eldöntő algoritmus működési elve Ez a része az algoritmusnak elég tisztán és világosan van leírva Lippner Gábor cikkében, semmilyen átalakításra nem volt szükség a programozás előtt. Az alábbiak pusztán technikai információk. Vezessünk be néhány elnevezést: Egy körpár horizontális, ha bármelyik tagjától a gyökérig vezető úton nincs rajta a pár másik tagja. Minden egyéb esetben vertikális kör párról beszélünk, és a kör pár azon tagja, mely rajta van a másiktól a gyökérig vezető úton, a kör pár felső tagja, míg a másik az alsó. Double Swicth Adatstruktúrának a gyökérrel rendelkező fák egy megszokott tárolási módját választottuk. (Minden csúcsra tároljuk egy gyerekét, jobb- és baltestvérét, továbbá a szülőt.) Az egyetlen nehézség ebből akkor adódik, amikor egy körpárnak megfelelő élpár vertikális. Ha horizontális körpárral van dolgunk, akkor nagyon egyszerű a Double Switch megvalósítása, csupán meg kell cserélni a két él alatti részfákat. Ha azonban vertikális az él pár, akkor a közöttük lévő úton található összes élen meg kell fordítani, a szülő-gyerek viszonyt. Hurkolódás ellenőrzése Ehhez azt az észrevételt alkalmaztuk, hogy két él pár pontosan akkor nem hurkolódik, ha bármelyiket is választjuk a két élpár közül, a tagjai között vezető úton vagy nincs a másik élpárnak tagja, vagy mindkét tagja rajta van. Hurkolódási gráf Éllistával tároljuk. Két színnel való színezésre pedig a következő természetesen adódó algoritmust alkalmazzuk: megkeressük az első még nem színezett pontot, majd minden szomszédját ellenkező színűre színezzük, valamint betesszük egy listába. Ez után a várólistából választjuk a következő elemet, és színezetlen szomszédjait kiszínezzük, listába tesszük, a színezettekre pedig ellenőrizzük, hogy ellenkező színűek-e. (Ha nem, akkor kilépünk nemleges válasszal.) Ha a lista kiürül, megint keresünk egy nem színezettet (ezzel egy újabb komponenst) amíg mindent ki nem színeztünk.
A konstrukció előállítása
12
A konstrukciót is az inverzió utáni feladatra adunk. (Valójában ezen konstrukció kedvéért alkalmaztuk az inverziót.) Viszont még így sem teljesen kézen fekvő a dolog, és a problémát ezúttal azok a horizontális párok fogják jelenteni, melyek tagjai között vezető úton egy másik horizontális pár található. Az algoritmus további része szempontjából lényegtelen, hogyan helyezzük el az alapköröket, ezért minden körre egy kisebb koncentrikus körön rendezzük el a közvetlen leszármazottakat, kivéve ha csak egy leszármazott van, amikor egy picivel kisebb koncentrikus kört helyezünk el. Ez utóbbi azért fontos, mert a Double Switchek során létrejött duplázott köröket egymás mellett akarjuk tartani. Sorrend Ez után meghatározzuk a körpárok csövekkel történő összekötésének sorrendjét. Úgy akarjuk véghez vinni az összekötéseket, hogy minden lépésben egy párt kötünk össze, és minden pár összekötésére egy külön vízszintes irányú sávot fogunk fenn tartani, ezáltal kerüljük el a metszéspontokat. Éppen ezért fontos a sorrend. (Leginkább az a fontos, hogy melyik „magasság sávot” melyik körpárnak osztjuk ki, de ezt a sorrend alapján fogjuk megadni.) A következőképpen fogjuk egységekre bontani a fát. Minden körhöz hozzá rendelünk egy (esetleg üres) egységet, amit a következő algoritmus határoz meg: 1. Vegyük az összes közvetlen leszármazottat bele az egységbe 2. Minden vertikális leszármazottra vegyük hozzá a párját, és annak közvetlen leszármazottait. 3. Ismételjük az első lépést amíg van vertikális kör, melynek párja még nincs az egységben. Nevezzük összekötésnek azt, amikor minden körpárt összekötünk csövekkel. (Tulajdonképp egy ilyen összekötést keresünk.) Vegyük észre, hogy tetszőleges összekötés esetén egy adott kör párhoz tartozó csövön belüli csöveket meghatározó körpárok ugyanazok, sőt az sem függ magától az összekötéstől, hogy a csövön belüli tartományból elhagyva a benne lévő csövek belsejét mely körpárokhoz tartozó csövek fogják alkotni a kapott tartomány határát. A fenti egységekben pontosan ezen körpárok tagjai lesznek, feltéve, hogy a kör, amiből kiindultunk nem vertikális pár alsó tagja.
13
Továbbiakban nevezzük a körpár egységének azt az egységet mely: 4. A pár két tagjának egységének egyesítése, ha a pár horizontális 5. A felső kör egysége ha a pár vertikális. Még szükségünk lesz egy további fogalomra is. Nevezzünk egy horizontális párt fő horizontális párnak, ha a pár mindkét tagja ugyanannak a körnek az egységében van, és másodlagosnak, ha egy horizontális pár két különböző tagjában van. Ez után az egységeken belüli sorrendtől azt követeljük meg, hogy a vertikális párok legyenek az elsők, őket kövessék a fő horizontális párok, és legutoljára foglalkozunk majd a másodlagos horizontális párokkal. Az egységek sorrendjéről kizárólag azt követeljük meg, hogy egy egységet csak abban az esetben kezdhetünk el, ha a benne található összes kör egységével már végeztünk. Bizonyítandó, hogy van ilyen sorrend. Ezt úgy hajtjuk végre, hogy megadjuk az algoritmust, mely a sorrendet elkészíti. Készítünk egy függvényt, melynek argumentuma egy körpár. Ez meghívja sajátmagát minden saját egységébe tartozó körpárra (ügyelve arra, hogy egységen belül helyes sorrendben hívja meg a körpárokat), illetve ha nincs már több ilyen , akkor felírja magát a már elkészült lista végére. Vegyünk fel egy segédkört, melynek nincs párja, és minden más kört tartalmaz. Ennek egysége legyen magának a körnek az egysége. Erre a segédkörre meghívjuk a függvényt. Ez által helyes sorrendben felíródnak azok a párok, melyeket elértünk. Kell, hogy minden párt elérünk. Tegyük fel indirekt, hogy nem így van, és vegyünk egy olyan kört, mely nem elért párhoz tartozik, és ilyenek közül legfelső, olyan értelemben, hogy tőle a gyökérig vezető úton nincs még egy ilyen. Ez azonban benne van egy, az előbbi úton lévő körnek az egységében, ami ellentmondás. (Csak akkor nem világos, hogy benne van egy ilyen egységben, ha szülője alsó vertikális, ekkor azonban a szülő párja felső vertikális, mely elért, és azonos egységben van a kérdéses körrel, ami újra ellentmondás.) Kötések Minden cső 3 részből fog állni: két oszlopból, és egy hídból. Az oszlopok egy-egy, a két kör fölé állított henger legyen. Ezek magassága éppen annyi, mint ahányadik sorszámot a körpár kapta az előbbi sorrendbe rakásnál. A vertikális körök esetén a híd, egyszerűen a pár egy körgyűrű segítségével való lezárása. (Gyakorlatban készítünk egy másolatot az általuk síkban határolt tartományt alkotó háromszögekről, és azokat a megfelelő magasságba
áthelyezzük.) A fő horizontális párok esetén a 9. oldalon tárgyalt tetszőleges út problémára hivatkozunk. Az oszlopok tetejére egy könyök csövet helyezünk (ld.: az ábrán) mely egy előre kiszemelt él fölé fordítja a csővéget, majd egy – az alap sík háromszögelését követő – út mentén összekötjük a két szabadon maradt véget. Mindössze arra vigyázunk, hogy egységbe tartozó horizontális körpárhoz tartozó kör élét ne lépjük át menetközben. Ez elég, hiszen az egységbeli vertikálisakat már lezártuk, a többi egység pedig vagy egy már lezárt vertikális alatt van, és akkor megint csak lezárt, vagy az előbbi tiltás mellett nem
14
tudunk elérni olyan élet, ami nem tartozik az egységbe. Tehát egyetlen hengert sem metszhettünk át. Ez így tökéletes is volna, ha nem lennének másodlagos horizontális csövek, de nem hogy ilyenben nem reménykedhetünk, de ez még speciális eseteket sem old meg, mert a double switchek éppen ilyen másodlagos párokat hoznak létre nagyon sokat. (Kivéve ha minden pár vertikális típusú.) A másodlagos horizontális körök összekötésénél a nehézséget éppen az okozza, hogy egy másik csövön belül – annak vonalát követve – kell összekötni a pár két tagját, mindezen közben ügyelve arra, hogy a csövön belül haladó esetleg több másodlagos pár ne metssze egymást. Ezt úgy fogjuk megvalósítani, hogy a hidat annak a horizontálisnak körpárnak a hídjával együtt építjük meg, amelyiknek az egységében van. Ez utóbbit nevezzük továbbiakban tartalmazó körpárnak. A tartalmazó körpár összekötése előtt az egyik oldalon emeljük olyan magasra a másodlagos körpárok feletti oszlopokat, amilyen a tartalmazó körpár oszlopa. Mikor a tartalmazó körpár hídját építjük, akkor azt nem kör keresztmetszettel építjük, hanem a másodlagos körpárok csöveinek megfelelő további egyik oldalon lévő köröket is hozzá vesszük a keresztmetszethez, így egy cső köteget húzva. Ez által a tartalmazó körpár már összekötött. A probléma most abból adódik, hogy a másik oldali körök elrendezése különbözhet. Ezért mindkét oldali megfelelő körlapokat feleakkorára zsugorítjuk a híd azon végénél, ahol nem emeltük meg a csővégeket, úgy hogy a két oldali körlapok képei egymást csak érintsék. Egy közös háromszögelést veszünk, és újra a 9. oldalon leírt algoritmussal az új háromszögelés elemei fölött kötjük össze a másodlagos horizontálisakat. (Mindegyiket a neki megadott magasságban.) Ezúttal a tiltott élek, a másodlagos horizontális körök tagjainak élei. Állítás Ezzel minden körpárt összekötöttünk. Végül a double switchek során létrejött duplázott körpárok csöveit az egyik végen össze húzzuk egy körív mentén. Ez valójában egy érintésnek felel meg, de miután a modell szempontjából nem lényeges, hogy valóságban mely háromszögek csatlakoznak egymáshoz, azzal már nem törődünk, hogy valóban átalakítsuk az érintéseket metszésekké. Miért nem tetraédereken keresünk? Ennek elsődleges oka abból adódik, hogy szükség van valamilyen módra, ami biztosítja, hogy az egyes alapkörök egy-egy háromszögön belül helyezkednek el. (Hiszen itt nem lenne
15
egy extra dimenziónk mint a fenti algoritmusnál arra, hogy ezt magunk garantáljuk a csövek húzása során.) Viszont ha egy körön belüli kört párjával összekötöttünk, akkor ez már lehetetlen volna az őt tartalmazó kör esetében, hiszen tovább bontottuk a háromszögelést. Ha viszont kívülről haladunk befelé, akkor a belső kört úgy kéne elhelyezni, hogy valamelyik már meglévő lapon belül legyen, ami drasztikusan lecsökkentené a körök méretét pár egymásba ágyazott kör esetén is, tehát hamar jelentőssé válnának a számítási hibák. (Valójában az első változat ezt a módszert követte, de 3 egymásban lévő körre, már reménytelenül nagyok voltak a számítási hibák, még double változó típus esetén is.) Nem beszélve arról, hogy a Double Switch-ek során egymásba ágyazott kör párok jönnek létre, melyeket egymás közelében kell tartsunk, ami ez esetben nem lenne megvalósítható. Számítási hibákból eredő további problémák Az a háromszögelő algoritmus, amit korábban megadtunk, sajnos ebben az esetben nem alkalmazható sikerrel, mert nagyon hamar a számítási hibák felgyülemlenek. Ezen probléma megoldása érdekében nem az alap háromszögeléséből indulunk ki, hanem egy nagyon finom négyzet hálónkeresünk. További probléma, hogy az eredeti verzióban minden csövet egy él szélességére csökkentünk, ami megint egy exponenciális csökkenést eredményez. Éppen ezért azokban az esetekben ahol nem kell kikerülnünk semmit nem, indítjuk el a Dijksztra algoritmust, hanem egyenesen kötünk össze. Ez ráadásul az ábrák áttekinthetőségét is jelentősen javítja.
16
Néhány a program által generált felület 0,0,1,2,1,2,7,7,7,1,8
0,0,0,1,2,2 Az alábbiakban néhány olyan modellt mutatunk be, melyeket a felületgeneráló program 0,0,0,1,4,0 készített. A modelleket OBJ formátumban importálja a vizualizáló rendszer darabokban, és itt van mód az anyagok1 hozzárendelésére. Az áttekinthetőség végett, más-más anyagot kaptak egyes csövek sőt, a körök fölé emelt hengerek, és az őket összekötő csövek is bizonyos esetekben. Szintén az áttekinthetőség érdekében az inverziótól is eltekintettünk, ami a síkot az egységgömbbe transzformálná.
Kód: 0,0,0,1,2,2
1 Vizualizáló rendszerekben anyagnak hívjuk azt adat halmazt, ami jellemzi egy adott felületdarab fényvisszaverési tulajdonságait. (Így például a színét, az érdességét, átlátszóságát.)
17
18
Kód: 0,0,0,1,4,0
19
Kód: 0,0,1,2,1,2,7,7,7,1,8
20
21
Érdekességek Elsőként arra a kérdésre kerestük a választ, hogy mennyire fontos a double switchek szerepe a Lippner féle algoritmus során. A következő oldalon található táblázat azt mutatja, hogy látszólag nem megkerülhető a dolog, hiszen az érintéssel való megvalósíthatóság teljesen független a transzverzális megvalósíthatóságtól. Megjegyzés A táblázatban szereplő példák minimálisak. Bizonyítás Az első esetben ez triviális. Egyetlen körpárra viszont nincs is más konfiguráció, tehát a második esethez legalább kétkör pár szükséges. (Természetesen ha más pontból vetítünk sztereografikusan, akkor lehet, hogy a 0,1 kóddal meghatározott fát kapjuk, de az ugyan az.) Ahhoz, hogy egy hurokmentes gráfban páratlan kör legyen, legalább három pont szükséges, tehát ha egy kör pár rendszer nem érintő megvalósítható, akkor biztosan legalább három körpárt tartalmaz. † A táblázat utáni oldalon megtalálhatóak a szemléltető ábrák a megvalósítható esetekhez. Megadjuk az összes legfeljebb három kör párból álló rendszert. Az egy kör pár esetét fentebb tárgyaltuk. Az alábbi táblázat tartalmazza az összes 2 párból álló rendszert valamint, hogy melyek transzverzálisan megvalósíthatóak. (Az érintő megvalósíthatóságról már láttuk, hogy két kör esetén automatikus.) Mint látszik egyetlen olyan eset van amikor transzverzálisan nem megvalósítható az immerzió. 0,1,0,3
0,3,0,0
0,3,1,0
0,1,0,0
0,0,1,2
0,0,0,0
Állítás Nincs olyan három körpárból álló rendszer, ami nem izomorf a fentiek valamelyikével. Bizonyítás 1) Nincs több gráf. Triviális. 2) Nincs több párba állítás, és ezek valóban különböznek. Az út esetén a párjukkal szomszédos élek száma egyértelműen meghatározza a párba állítást. Ha van negyedfokú pont, akkor triviális, hogy lényegében egyértelmű a színezés. Az egy harmadfokú ponttal rendelkező fa esetén a harmadfokú pontból szükségképpen indul egy párba tarozó két él, és egy olyan aminek a párja, nem a harmadfokú ponthoz csatlakozik. Ez utóbbi él által meghatározott pár szomszédsági viszonya jellemzi a színezést. † Állítás Nincs olyan három körpárból álló rendszer, ami nem izomorf a 25. oldalon kezdődő táblázatban található rendszerek valamelyikével. Bizonyítás Ugyanúgy megy, mint az előbbi, csak jóval több esetet kell ellenőrizni. Kényelmes invariánsok: gráf-szomszédos élpárok, adott fokú (tipikusan legnagyobb fokúé érdekes) csúcshoz csatlakozó egy párban levők száma. Leghosszabb úthoz való viszony. † Megjegyzés Izomorfia erejéig összesen 68 különböző 3 körpárból álló rendszer adható meg. Ezeket a párosítatlan fák izomorfia osztályai szerint csoportosítottuk. Meglepően kevés a nem meg valósítható rendszer: érintés esetén 10, transzverzális esetben 25, és csak 6 olyan van, ami egyik esetben sem valósítható meg.
22
0,0
0,3,1,0
0,0,0,1,4,0
Fa
Konfiguráció
Kód Érintô m. Transzv.
Double Switch utáni fa hurkolódási gráfja
Double Switchek utáni fa
Hurkolódási gráf
23
0,3,1,0,1,4
Első eset, melyben mindkét kérdésre igen a válasz:
Második esetben csak az érintő megvalósíthatóság igaz:
Valamint a harmadik gráf transzverzális esete:
24
Három kör párból álló rendszerek Érintö megv.
Transv. megv.
1.1
0,0,1,3,2,5
I
I
1.2
0,1,0,2,3,5
I
I
1.3
0,1,0,3,2,4
I
I
1.4
0,3,0,2,1,5
I
N
1.5
0,1,0,5,3,2
I
N
1.6
0,0,1,2,3,4
I
I
1.7
0,0,1,5,2,3
I
N
1.8
5,0,0,6,2,3
I
N
1.9
5,0,0,6,3,2
N
I
1.10
5,0,0,2,3,4
I
N
1.11
5,4,0,6,3,0
I
N
1.12
5,6,0,2,3,0
I
N
2.1
0,0,0,3,4,5
I
I
2.2
0,0,0,5,3,4
I
N
2.3
0,0,0,6,3,5
I
I
2.4
0,0,0,1,4,5
I
I
2.5
0,0,0,5,1,4
I
N
2.6
0,0,0,6,1,5
I
I
2.7
0,1,0,2,0,4
I
I
2.8
0,5,0,6,0,2
I
N
2.9
0,5,0,2,0,4
N
N
3.1
0,0,0,6,3,1
N
N
3.2
0,0,0,1,3,4
I
I
3.3
0,0,0,3,1,5
I
I
3.4
0,0,0,5,3,1
I
N
Azonosító
Kód
Tartó fa
Párosított fa
25
3.5
0,0,0,3,4,1
I
I
3.6
0,0,0,1,3,5
I
I
3.7
0,1,0,2,0,3
I
I
3.8
0,5,0,1,0,2
I
N
3.9
0,4,0,5,0,1
N
N
3.10
0,5,0,2,0,1
N
N
3.11
0,1,0,6,0,5
I
I
3.12
0,1,0,5,0,4
I
N
4.1
0,0,0,0,1,5
I
I
4.2
0,0,0,5,0,4
I
N
4.3
0,0,0,6,0,5
I
I
4.4
0,0,0,1,0,4
N
I
5.1
0,0,0,3,1,1
I
I
5.2
0,0,0,1,3,3
I
I
5.3
0,0,0,1,2,2
I
I
5.4
0,0,0,1,1,3
N
I
5.5
0,1,0,5,0,1
I
N
26
5.6
0,0,0,3,3,2
I
I
5.7
0,1,0,1,0,5
I
I
5.8
0,5,0,1,0,1
I
N
5.9
0,0,0,1,1,2
I
I
6.1
0,1,0,1,3,3
I
I
6.2
0,0,1,1,2,2
I
I
6.3
0,0,1,2,1,2
I
I
6.4
0,3,0,1,1,3
N
N
6.5
0,1,0,3,1,3
I
I
7.1
0,0,0,0,1,2
I
I
7.2
0,0,0,5,0,3
I
N
7.3
0,0,0,1,2,0
I
I
7.4
0,0,0,1,0,5
I
I
7.5
0,0,0,5,0,1
I
N
7.6
0,0,0,0,2,4
I
I
27
8.1
0,0,0,3,2,1
I
I
8.2
0,0,0,1,2,3
N
I
8.3
0,1,0,3,0,5
I
I
8.4
0,1,0,5,0,3
I
N
8.5
0,5,0,1,0,3
N
N
9.1
0,0,0,5,0,5
I
I
9.2
0,0,0,0,1,1
I
I
9.3
0,0,0,1,0,1
I
I
10.1
0,0,0,0,0,5
I
I
10.2
0,0,0,0,0,1
I
I
11.1
0,0,0,0,0,0
I
I
28
Észrevételek Lippner Gábor cikkéből világos, hogy érdemes vizsgálni az olyan immerziókat, melyek beágyazások eltekintve körök mentén való érintésektől. Ha az összes felületre ismernénk ennek a feladatnak a megoldását, akkor visszavezethető lenne a transzverzális eset erre. Vegyük észre azt, hogy ha csak érintés típusú kettőspontok vannak, akkor a felület irányítható, ugyanis ³-ba nem lehet nem irányítható felületet beágyazni, márpedig egy ilyen immerziónak megfeleltethető egy beágyazás. Tehát a továbbiakban feltehetjük, hogy valamilyen g-génuszú irányítható felületről beszélünk. Ekkor ha adott egy érintéses immerzió, akkor végrehajthatjuk ugyanazt a műtétet, mint Lippner cikkében, melynél a kettősgörbe feletti X nyalábot lecseréltük egy H nyalábra. (Lásd.: az ábrát)
A null homotóp görbék esete Azt az esetet vizsgáljuk, mikor az összes felületre rajzolt görbe úgy bontja két részre a felületet, hogy az egyik keletkező peremes felület körlap, melyet egy k kör esetén jelöljön k°! Ekkor az is igaz, hogy minden kettős görbe őse két kör, így a kapott összekötés valójában egy henger. Ez általában nincs így, ugyanis például a tórusznak létezik olyan érintéses immerziója, melynél egyetlen kettőskör keletkezik, ami önmagát fedi az immerziónál. Ehhez vegyünk egy kört, ami önmagát egyetlen pontban érinti, és vegyük az ábrán látható ilyen fibrumú nem triviális fibrálást a kör felett. Ilyenkor a fenti műtét során egy möbiusz szalag keletkezik. Vegyük észre, hogy ha a génusz nem nulla, és továbbra is felteszzük, hogy minden kör úgy bont ketté, hogy egyik oldalán körlap van, akkor van értelme beszélni külső tartományról. (Az a tartomány, amelyet az összes körlap elhagyásával kapunk.) Lemma A g-génuszú irányítható felület mindig előáll úgy egy 0-cellából, 2g 1-cellából, és egy 2-cellából CW-komplexusként, hogy az 1-váz része a külső tartománynak. Bizonyítás Világos, hogy létezik a felületen olyan körlap, mely tartalmazza az összes megadott körlapot, és ebből egy diffeotópával kifújhatjuk az 1-vázat. † Ezzel tehát elértük, hogy egyetlen – a felületen található – körlap tartalmazza a körrendszer összes elemét. Világos, hogy a fentiek szerint adódik egy hasonló párosított fa ahhoz, amit a gömb esetén láttunk, de ezúttal egy természetesen adódó gyökérrel. Az algoritmus, amit a felület konstruálásnál alkalmaztunk bármely a körrendszert tartalmazó körlap fölé emelt elég magas 29
hengeren belül marad. Ez a henger tetszőlegesen kicsivé tehető, ha a konstrukciót teljes egészében összenyomjuk a függőleges tengely irányban. Viszont ekkor a nyílt henger beágyazható a g-génuszú felület csőszerű környezetébe úgy, hogy a beágyazás a körlapon, éppen a 2-cella karakterisztikus leképezése. Tétel Minden olyan körrendszer megvalósítható g-génuszú felület érintéses immerziójával, melynek körei null homotópok, és a kapott gyökeres fa olyan, hogy ha elfelejtjük, hogy van gyökere, akkor izomorf egy megvalósítható gömbi rendszer párosított fájával. Továbbá ha a körökről megköveteljük, hogy null homotópok, akkor más nem is valósítható meg. Bizonyítás Az egyik irányt már beláttuk a fenti konstrukcióval. A másik irányhoz már láttuk, hogy a kettős körök mentén van értelme a műtétnek, és azt is, hogy jelen esetben mindig hengert kapunk. Sajnos azonban az nem tehető fel általánosságban, hogy van olyan izotópia, ami a g-génuszú már beágyazott felületet a standard beágyazásba viszi át. Az viszont itt is könnyen belátható, hogy egymással hurkolódó körpárokat összekötő csövek nem eshetnek a felület ugyan azon oldalára. A feltétel ugyanis, mely szerint egy M körpárnak megfelelő élek közti úton pontosan az egyik éle van rajta az N körpárnak a következő két esetre bontható aszerint, hogy az M kör pár horizontális, vagy vertikális típusú: 1. Ha vertikális, akkor a felső vertikális kör – jelölje m1 – által megadott körlapban van az M és az N kör párnak is pontosan egy tagja, éspedig az N-ben lévő n1 kör tartalmazza az M másik m2 körét, az n2 kör lapja pedig diszjunkt a másik három körlaptól. Ekkor m1°\m2°»MT egy gömbfelület, melyen rajta van n1 de diszjunkt tőle n2, sőt még ezen gömb belsejétől is. (MT az M párt összekötő csövet jelöli.) Most ha feltesszük, hogy NT a felületnek ugyan azon az oldalán van, akkor n1-tôl elég kicsi e >0 távolságra NT-en lévő pontok nem köthetőek össze még úttal sem n2 egyetlen pontjával sem úgy, hogy ne metsszék MT-t és a felületet. Tehát csővel még úgysem. 2. Ha horizontális, akkor M első tagja – jelölje m1 – által meghatározott körlap tartalmazza n1-et, továbbá m2 és n2 körlapjai diszjunktak. Ekkor m1°»m2°»MT lesz az a gömb, amire a fenti gondolat menet szinte szó szerint átvihető. Ekkor már az alábbi állítás teljessé teszi a bizonyítást.† Állítás Minden beágyazott null homotóp görbe határol egy körlapot. Bizonyítás Az ismeretes, hogy egy ilyen leképezés kiterjed a körlapra. Feltehető, hogy a felület háromszögelt, a beágyazott null homotóp görbe az egy váz része, és a körlap fenti leképezése szimpliciális leképezés, csak úgy mint a körvonalé. Ha minden háromszöglapot legfeljebb egy háromszöglap fed, akkor ez a körlap olyan beágyazása melynek határán a leképezés képe éppen az előre megadott, tehát készen vagyunk. Tegyük fel, hogy létezik két olyan háromszög lap, melyek ugyan oda képződnek. Ekkor azt állítjuk, hogy léteznek olyanok is, melyek még szomszédosak is. Ha ugyanis nincs ilyen, akkor tetszőleges párból indulva mindhárom szomszédjuk is páronként egy helyre képződik. Ha ezek szomszédjai sem ilyenek, akkor megint legalább egyel növelhető az ilyen háromszöglapok száma. Ez pedig ellentmondás azzal, hogy csak véges sok háromszög jöhet szóba. (Ha a két komponens összeér, akkor olyan párt kapnánk, amilyenre szükségünk van, tehát az indirekt feltevés szerint ez nem lehetséges.) Egy ilyen pár viszont eliminálható. A két háromszög a leképezésnél „egymásra hajtódik” melynek során a jobb oldali ábrán azonos színnel jelölt szakaszok lineárisan egymásra képződnek. A bal oldali ábra szakaszait egy pontba csíphetjük, és a kapott pontot képezzük ennek a szakasznak végpontjainak közös képébe. Ekkor továbbra is szimpliciális a leképezés, de egyel kevesebb az olyan háromszög pár, ami ugyanarra a háromszögre képződik. †
30
Egy nagyon speciális eset Tegyük fel most hogy van nem null homotóp osztály, és minden önmetszés transzverzális. A tórusz esetén a null homotópia ekvivalens azzal, hogy az adott osztály null homológ. Állítás Ha egymást nem metsző beágyazott zárt görbéket veszünk a tóruszon, és vesszük ezek homológia osztályait, akkor legfeljebb egy nem nulla osztály jöhet szóba irányítástól eltekintve, mely ráadásul választható x generátorai közül az egyiknek. Bizonyítás Ehhez a tórusz kohomológiát kell megvizsgálnunk: a generátorok a és b melyek egy 2-et generálnak, továbbá: a2=b2=0 és ab=-ba=1. Tehát (xa+yb)(va+wb)=xw-yv=0 feltétel azt jelenti, hogy (x,y) és (v,w) együtt is csak egy -t generálnak. Az alábbi lemmából már következik az állítas. † Lemma Ha H1(Tórusz) egy eleme többszöröse egy másiknak, akkor nem lehet beágyazott görbével reprezentálni. Bizonyítás Tegyük fel, hogy mégis! Ekkor tekintsük a tóruszt mint 2/(x) faktor teret. (Ez egy fedés is.) Vegyük a görbe (0,0) kezdőpontú felemeltjét, és tegyük fel, hogy ez a (p,q) pontban végződik. (Feltehető p
0 Most vegyük a (p/d, q/d) kezdőpontú felemeltet. A (0,0) kezdőpontú felemelt görbe ettől is diszjunkt kell legyen, minek következtében ha például az előbbi végpont x koordinátája q/d+c volt, akkor a 2p/q lépés után kapott végpont vízszintes irányú koordinátája 2q/d+c-nél nagyobb. Ezt folytatva kapjuk, az állítást.† Tehát a nem nulla homológia osztály választható x generátorának, ami pedig azt jelenti, hogy feltehető, hogy ez a homológia osztály éppen a tórusz meridiánja. Feltétel A továbbiakban csak azzal az esettel foglalkozunk, mikor a meridián reprezentálja tehát a szóba kerülő nem nulla homológia osztályt, és ennek képe olyan leképezése a körnek, mely beterjed egy körlapra úgy, hogy nincsenek háromszoros pontok, még a tórusszal együtt sem, és a körlap kettőspontjai a körlapon belül maradnak. Ilyen létezése a fenti standard beágyazással való izotópia hiányában nem automatikus: elképzelhető, hogy a meridián kettős görbe őse, és csomóba képződik, amikor nem lehetséges
31
ilyen beágyazott körlapot választani. (Lásd.: fenti ábrát.) Sőt az is előfordulhat, hogy két meridiánt reprezentáló görbe képe láncot alkot, mint például az alábbi ábrán Hopf-linket. A következő műtétet hajtsuk végre: vegyük az imént kiválasztott görbét, és vegyük a beágyazott körlapot. Ezzel a körlappal átalakítjuk a tóruszt gömbbé úgy, hogy a görbe mentén felvágjuk a tóruszt, és a keletkező lyukakat beragasztjuk a körlappal. (Két külön példányával.) Kis perturbáció után a gömb öntranszverzális háromszoros pont mentes immerzióját kapjuk. Most is van értelme felrajzolni azt a gráfot, melynek pontjai a tartományok, élei pedig a tartományok szomszédsági relációjának felelnek meg. Ezen a gráfon következőnek felel meg a tórusz előbbi műtéte: van egy egyértelmű kör a gráfban, ennek egy pontját megkettőzzük, és valahogyan elosztjuk a belőle kiinduló éleket. A két példány mindegyikére 1-1 új élet illesztünk, mely a műtétnél használt görbének felel majd meg, ezek alkossanak egy párt. Illesztünk mindkét oldalra egy-egy fát, melyek izomorfak. Ez után minden illesztett fabeli b élre választhatunk tetszőleges pontot az eredeti gráfból, beillesztünk egy a és egy c élet, melyek párjai b és d lesznek, ahol d azaz él a az izomorf másik élhez illesztett fából, ami b-nek felel meg. Világos, hogy pontosan akkor létezik a tórusznak kívánt típusú immerziója, ha lehet a fenti szabályok szerint eljárva olyan fát létrehozni, ami a gömb immerzióját adja.
32
Függelék - Forrás kódok Jones Polinomok és Kauffman zárójelek for(i=1;i<16;i++){ //Ez a program reszlet felelos a rajzmezo for(j=1;j<16;j++){ //letrehozasaert. duplicateMovieClip("Alkoto0x0","Alkoto"+i+"x"+j,i*16+j); setProperty("Alkoto"+i+"x"+j,_x,i*20-20); setProperty("Alkoto"+i+"x"+j,_y,j*20-20); this["Alkoto"+i+"x"+j].XPos=i; this["Alkoto"+i+"x"+j].YPos=j; } } Alkoto0x0._visible=false; setProperty("chosen_construct",_visible,false); duplicateMovieClip("chosen_construct","chosen",1000); setProperty("chosen",_visible,false); frm=1; j=1; k=1; for(i=1;i<12;i++){ //Ez a rész a rajz eszközöket hozza létre j=j+1; if(j>4){ j=1; k=k+1; } duplicateMovieClip("swap","swap"+i,300+i*4+j); setProperty("swap"+i,_x,j*20+290); setProperty("swap"+i,_y,k*20-10); if(k==1&&j>2){ setProperty("swap"+i,_x,j*20+290); setProperty("swap"+i,_y,k*20+10); } if(k==2&&j>2){ setProperty("swap"+i,_x,j*20+290); setProperty("swap"+i,_y,k*20-30); } this["swap"+i].gotoAndStop(i); } swap._visible=false; frm=1; function chk(){ //Ellenörizzük, a görbék zártságát. var i; var j; //Valójában csak annyit teszünk, hogy okay=true; //ellenörizzük, hogy a négyzetet elhagyó for(i=1;i<15;i++){ //görbének van-e folytatása. for(j=1;j<15;j++){ cf=this["Alkoto"+i+"x"+j]._currentframe; this["Alkoto"+i+"x"+j].presign=0; cfv=this["Alkoto"+(i+1)+"x"+j]._currentframe; cff=this["Alkoto"+i+"x"+(j+1)]._currentframe; if(not(cf<4||cf==7)&&(cfv==1||cfv==4||cfv==5||cfv==7)){ okay=false; } if((cf<4||cf==7)&¬(cfv==1||cfv==4||cfv==5||cfv==7)){ okay=false; } if(not(cf<3||cf==5||cf==6)&&(cff==1||cff==3||cff==4||cff==6)){ okay=false; } if((cf<3||cf==5||cf==6)&¬(cff==1||cff==3||cff==4||cff==6)){ okay=false; } if(not(cfv<4||cfv==7)&&i==14){ okay=false; } if(not(cf==1||cf==4||cf==5||cf==7)&&i==1){ okay=false; } if(not(cff<3||cff==5||cff==6)&&j==14){ okay=false; }
33
if(not(cf==1||cf==3||cf==4||cf==6)&&j==1){ okay=false; } } } return(okay); } //Az alabbi fuggvény szolgal a kaufmann zarojel, //illetve kaufmann polinom megjelenítésére. //Argumentum: type //Értéke: B ha zarojelet szamitunk, bármi mas //(javasolt ertek: P) ha polinomot. function kaufmann(Type){ var i; var j; var W; polyArray1=kaufmannArray(chainArray(),1); if(Type=="B"){ polyArray=polyArray1; }else{ W=numberOfComponents(chainArray(),true) polyArray=arrayDuplicator(polyArray1,Math.pow ((-1),W)); polyArray[0]=polyArray[0]-3*W; } polyText=""; j=0; for(i=1;i<polyArray.length;i++){ if(not polyArray[i]==0){ if(j>0&&polyArray[i]>0){ polyText=polyText+"+"; } if(polyArray[i]<0){ polyText=polyText+"-"; } if(Type=="J"){ polyText=polyText+Math.abs(polyArray[i])+"("+(-(i-1+polyArray[0])/4)+")"; }else{ polyText=polyText+Math.abs(polyArray[i])+"("+(i-1+polyArray[0])+")"; } j=1; } } return(polyText); } //Ez a fuggveny tolti be a rajz mezobol az adatokat egy tombbe function chainArray(){ var i; var j; chain=new Array(225); for(i=1;i<16;i++){ for(j=1;j<16;j++){ chain[15*(i-1)+j]=this["Alkoto"+i+"x"+j]._currentframe; } } return(chain); } //Ez szamolja ki a fenti tomb adataibol a kaufmann zarojelet //Keres egy kettospontot, es ha talal ilyet, akkor lecsereli //mind a ket fele kepen, majd rekurziven meghivja onmagat, //vegul elvegzi a szukseges muveleteket. Ha nem talal kettospontot //akkor elert egy allapotot (ld.: az eredeti cikket) tehát a //komponensek szamat kell megallapitani, es az alapjan meghatarozni //a visszateresi erteket. function kaufmannArray(chain,k){ var i; var j; var polz1; var polz2; var chain1; var chain2; var RetVal; var RetVal1; var RetVal2; for(i=k;i<226;i++){
//Kettospont kereses
34
frm=chain[i]; if(frm==8){ chain1=arrayDuplicator(chain,1); chain1[i]=11; chain2=arrayDuplicator(chain,1); chain2[i]=10; polz1=kaufmannArray(chain1,i); polz2=kaufmannArray(chain2,i) return(twistedSum(polz1,polz2,1)); } if(frm==9){ chain1=arrayDuplicator(chain,1); chain1[i]=10; chain2=arrayDuplicator(chain,1); chain2[i]=11; polz1=kaufmannArray(chain1,i); polz2=kaufmannArray(chain2,i) return(twistedSum(polz1,polz2,1)); }
//Ketfele kettospont van //ez itt az egyik tipus kezelese //lemasoljuk az //adatokat es a kettospontban //ahol kell, mindket //lehetseges modon. //Visszaterunk a megfelelo //ertekkel. //es ugyan ez a masik esetben
} RetVal=new Array(2); RetVal[0]=0; RetVal[1]=1; noc=numberOfComponents(chain,false); for(i=1;i<noc;i++){ RetVal1=arrayDuplicator(RetVal,-1); RetVal2=arrayDuplicator(RetVal,-1); RetVal=twistedSum(RetVal1,RetVal2,2); } return(RetVal); } function arrayDuplicator(array,c){ var i; var j; var Duplicate; Duplicate=new Array(); Duplicate[0]=array[0]; for(i=1;i<array.length;i++){ Duplicate[i]=c*array[i]; } return(Duplicate); }
//Adatok masolasa, es //c vel valo szorzas
function twistedSum(poly1,poly2,l){ var i; var j; poly1[0]=poly1[0]+l; poly2[0]=poly2[0]-l; return(polySum(poly1,poly2)); }
//Torzitott osszeg //melyet a kettospontok //lecserelesekor kell kepezni
function polySum(poly1,poly2){ //Hagyomanyos polinom osszeadas var i; var j; also=Math.min(poly1[0],poly2[0]); felso=Math.max(poly1[0]+poly1.length-2, poly2[0]+poly2.length-2); Val=new Array(felso-also+1); Val[0]=also; for(im=also; impoly1[0]-1&&im<poly1[0]+poly1.length-1){ Val[im-also+1]=Val[im-also+1]+poly1[im-poly1[0]+1]; } if(im>poly2[0]-1&&im<poly2[0]+poly2.length-1){ Val[im-also+1]=Val[im-also+1]+poly2[im-poly2[0]+1]; } } return(Val); } //Ez a fuggveny adja vissza a komponensek szamat. //Akkor is mukodik, ha nem diszjunktak a gorbek //bar az algoritmus szemontjabol ez nem lenne szukseges //Mukodese: Vegig megy az osszes negyzeten, es keres egy //meg nem talalt negyzetet, amin gorbe halad at. Ez utan //a gorben talalhato osszes negyzetet megjeloljuk, es //es feljegyezzuk, hogy talaltunk egy komponenst.
35
function numberOfComponents(chain,directing){ var i; var j; var k; var l; var side; var sign; var orient; compreg=new Array(225); comp=0; sign=0; for(i=1;i<15;i++){ for(j=1;j<15;j++){ ch=chain[15*(i-1)+j]; if(3
36
dir="T"; break; } break; default: switch(dir){ case "B": l=l-1; dir="B"; break; case "T": l=l+1; dir="T"; break; case "L": k=k+1; dir="L"; compreg[15*(k-2)+l]=1; break; case "R": k=k-1; dir="R"; compreg[15*(k-1)+l]=1; break; } } ch=chain[15*(k-1)+l]; if(directing&&(ch==8||ch==9)){ if(dir=="L"||dir=="B"){ side=orient; }else{ side=-orient; } if(this["Alkoto"+k+"x"+l].presign==0){ this["Alkoto"+k+"x"+l].presign=side; }else{ side=side*this["Alkoto"+k+"x"+l].presign this["Alkoto"+k+"x"+l].presign=0; if(ch==8){ side=-side; } sign=sign+side; } } if(k==i&&l==j){ exiter=1; }else{ if(directing&&(dir=="B"||dir=="R")){ this["Alkoto"+k+"x"+l].direr.gotoAndStop(1); } } if(exiter==1&&dir=="L"){ exiter=2; } }while(exiter<2) } } } if(directing){ return(sign); }else{ return(comp); } } //Torli a rajzolo mezo tartalmat function resetDisplay(){ for(i=1;i<16;i++){ for(j=1;j<16;j++){ this["Alkoto"+i+"x"+j].gotoAndStop(1); } } }
37
Immertált felületek minimális számú háromszoros ponttal Form1.frm VERSION 5.00 Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX" Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX" Begin VB.Form Form1 Caption = "Form1" ClientHeight = 6105 ClientLeft = 165 ClientTop = 855 ClientWidth = 11580 LinkTopic = "Form1" ScaleHeight = 6105 ScaleWidth = 11580 StartUpPosition = 3 'Windows Default Begin MSComctlLib.StatusBar SBar Align = 2 'Align Bottom Height = 285 Left = 0 TabIndex = 6 Top = 5820 Width = 11580 _ExtentX = 20426 _ExtentY = 503 _Version = 393216 BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} NumPanels = 1 BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} AutoSize = 1 Object.Width = 19897 EndProperty EndProperty BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 238 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty End Begin MSComDlg.CommonDialog CD Left = 2400 Top = 4440 _ExtentX = 847 _ExtentY = 847 _Version = 393216 End Begin VB.CommandButton Mover Caption = "^" Height = 300 Index = 3 Left = 8760 TabIndex = 5 Top = 5400 Width = 300 End Begin VB.CommandButton Mover Caption = "v" Height = 300 Index = 2 Left = 8400 TabIndex = 4 Top = 5400 Width = 300 End Begin VB.CommandButton Mover Caption = "<" Height = 300 Index = 1 Left = 8040 TabIndex = 3 Top = 5400
38
Width = 300 End Begin VB.CommandButton Mover Caption = ">" Height = 300 Index = 0 Left = 9120 TabIndex = 2 Top = 5400 Width = 300 End Begin VB.PictureBox Picture2 Appearance = 0 'Flat AutoRedraw = -1 'True BackColor = &H80000005& FillStyle = 0 'Solid ForeColor = &H80000008& Height = 3135 Left = 6240 ScaleHeight = 3105 ScaleWidth = 4185 TabIndex = 1 Top = 360 Visible = 0 'False Width = 4215 End Begin VB.PictureBox Picture1 Appearance = 0 'Flat BackColor = &H80000005& ForeColor = &H80000008& Height = 3855 Left = 0 ScaleHeight = 3825 ScaleWidth = 5625 TabIndex = 0 Top = 0 Width = 5655 End Begin VB.Menu mnuFile Caption = "&File" Begin VB.Menu mnuReset Caption = "&New" Shortcut = ^N End Begin VB.Menu Separator03 Caption = "-" End Begin VB.Menu mnuOpen Caption = "&Open" End Begin VB.Menu mnuSave Caption = "&Save" Index = 0 Shortcut = ^S End Begin VB.Menu mnuSave Caption = "Save &As..." Index = 1 End Begin VB.Menu mnuSeparator02 Caption = "-" End Begin VB.Menu mnuCalcTau Caption = "Calculate Tau" End Begin VB.Menu mnuExport Caption = "Export Geometry" Visible = 0 'False End Begin VB.Menu mnuSeparator05 Caption = "-" End Begin VB.Menu mnuExit Caption = "&Exit" Shortcut = +{F4} End End
39
Begin VB.Menu mnuView Caption = "&View" Begin VB.Menu mnuShowNod Caption = "Show Nod IDs" Checked = -1 'True End Begin VB.Menu menuShowDerivate Caption = "Show Derivates" End Begin VB.Menu mnuShowIntersect Caption = "Show Intersctions" Checked = -1 'True End Begin VB.Menu mnuShowAllPoints Caption = "ShowAllPoints" End Begin VB.Menu mnuSeparator01 Caption = "-" End Begin VB.Menu mnuShowGrid Caption = "ShowGrid" Checked = -1 'True End Begin VB.Menu mnuSnapToGrid Caption = "Snap To Grid" Checked = -1 'True End End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Dim PointHit As Integer Private Sub Form_Load() ReDim MainPoints(0 To 0) Form1.Caption = "New Document" ReDim Utacska(0 To 0) ReDim Backroot(0 To 0, 0 To 0) End Sub
'Kontrol pontok tárolására szolgáló tömb 'A form2be adja át a CalTau által keresett utat 'A form2 csak tesztelési célt szolgált.
Private Sub Form_Paint() Draw End Sub Private Sub Form_Resize() Picture1.Width = Me.ScaleWidth Picture1.Height = Me.ScaleHeight Picture2.Width = Me.ScaleWidth Picture2.Height = Me.ScaleHeight Mover(0).Top = Me.ScaleHeight - 900 Mover(0).Left = Me.ScaleWidth - 300 Mover(1).Top = Me.ScaleHeight - 900 Mover(1).Left = Me.ScaleWidth - 900 Mover(2).Top = Me.ScaleHeight - 600 Mover(2).Left = Me.ScaleWidth - 600 Mover(3).Top = Me.ScaleHeight - 1200 Mover(3).Left = Me.ScaleWidth - 600 PointHit = 0 Draw End Sub Private Sub Form_Unload(Cancel As Integer) End End Sub Private Sub mnuCalcTau_Click() ReDim MeshVertexs(0 To 0) 'Töröljük a háromszögelést ReDim MeshFaces(0 To 0) Form1.Enabled = False 'Letiltjuk a föablakot, hogy nehogy változás történjen frmOperation.Visible = True 'Progress bar megjelenítése DoEvents
40
Triangulate 'Háromszögelés készítése 'Form2.Visible = False frmOperation.Visible = False 'Tau kiszámítása már gyors, nem kell progress bar MsgBox CalculateTau 'Tau számítása, és megjelenítése Form1.Enabled = True 'Mostmár nem baj ha változás van End Sub Private Sub mnuExit_Click() Unload Form1 End End Sub Private Sub mnuReset_Click() ReDim MainPoints(0 To 0) 'Új dokumentum létrehozásához törlünk mindent ReDim AllPoints(0 To 0) ReDim Crossings(0 To 0) PointHit = 0 Form1.Caption = "New Document" Draw End Sub Private Sub mnuOpen_Click() 'Dokumentum megnyitása Dim inp As String Dim inpArray() As String mnuReset_Click CD.ShowOpen Open CD.FileName For Input As #1 Do If UBound(MainPoints) = 0 Then ReDim MainPoints(1 To 1) Else ReDim Preserve MainPoints(1 To UBound(MainPoints) + 1) End If Input #1, inp$ inpArray = Split(inp$) MainPoints(UBound(MainPoints)).X = Val(inpArray(0)) MainPoints(UBound(MainPoints)).Y = Val(inpArray(2)) Loop Until EOF(1) Close #1 Form1.Caption = CD.FileName End Sub Private Sub mnuSave_Click(Index As Integer) 'File mentése Dim FileName As String Dim i As Integer If Form1.Caption = "New Document" Or Index = 1 Then CD.ShowSave FileName = CD.FileName Else FileName = Form1.Caption End If Open FileName For Output As #1 For i = 1 To UBound(MainPoints) Print #1, Str$(MainPoints(i).X) + " " + Str$(MainPoints(i).Y) Next i Close #1 Form1.Caption = CD.FileName End Sub '------------------------------------ User Interface -----------------------------------Private Sub mnuShowAllPoints_Click() mnuShowAllPoints.Checked = Not mnuShowAllPoints.Checked Draw End Sub Private Sub mnuShowGrid_Click() mnuShowGrid.Checked = Not mnuShowGrid.Checked Draw End Sub Private Sub menuShowDerivate_Click() menuShowDerivate.Checked = Not menuShowDerivate.Checked Draw End Sub
41
Private Sub mnuShowIntersect_Click() mnuShowIntersect.Checked = Not mnuShowIntersect.Checked Draw End Sub Private Sub mnuShowNod_Click() mnuShowNod.Checked = Not mnuShowNod.Checked Draw End Sub Private Sub mnuSnapToGrid_Click() mnuSnapToGrid.Checked = Not mnuSnapToGrid.Checked Draw End Sub Private Sub Mover_Click(Index As Integer) Dim i As Integer For i = 1 To UBound(MainPoints) Select Case Index Case 0 MainPoints(i).X = MainPoints(i).X Case 1 MainPoints(i).X = MainPoints(i).X Case 2 MainPoints(i).Y = MainPoints(i).Y Case 3 MainPoints(i).Y = MainPoints(i).Y End Select Next i Draw End Sub
+ 300 - 300 + 300 - 300
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, _ X As Single, Y As Single) Dim Hit As Boolean, found As Boolean Dim i As Integer, UB As Integer Dim X1 As Double, Y1 As Double, L As Double, d1 As Double, d2 As Double If UBound(MainPoints) = 0 Then ReDim MainPoints(1 To 1) PointHit = 1 Else Hit = False For PointHit = 1 To UBound(MainPoints) If Abs(X - MainPoints(PointHit).X) < 50 And _ Abs(Y - MainPoints(PointHit).Y) < 50 Then Hit = True Exit For End If Next PointHit If Not Hit And Not Button = vbRightButton Then UB = UBound(AllPoints) ReDim Preserve MainPoints(1 To UBound(MainPoints) + 1) found = False Picture1.Circle (X, Y), 100, QBColor(12) For i = 1 To UB X1 = AllPoints(i Mod UB + 1).X - AllPoints(i).X Y1 = AllPoints(i Mod UB + 1).Y - AllPoints(i).Y L = Sqr(X1 ^ 2 + Y1 ^ 2) X1 = X1 / L Y1 = Y1 / L d1 = (X - AllPoints(i).X) * X1 + (Y - AllPoints(i).Y) * Y1 d2 = (X - AllPoints(i).X) * Y1 - (Y - AllPoints(i).Y) * X1 'Picture1.Circle (AllPoints(i).X, AllPoints(i).Y), 100 'MsgBox Str$(d1) + " " + Str$(l) + " " + Str$(d2) If d1 > 0 And d1 < L And Abs(d2) < 50 Then found = True PointHit = (Int(i / 10) + 1) Mod UBound(MainPoints) + 1 Exit For End If Next i For i = UBound(MainPoints) To PointHit + 1 Step -1
42
MainPoints(i).X = MainPoints(i - 1).X MainPoints(i).Y = MainPoints(i - 1).Y Next i If Not found Then PointHit = UBound(MainPoints) ElseIf Not Hit And Button = vbRightButton Then PointHit = 0 End If End If If Button = vbRightButton And Not PointHit = 0 Then If UBound(MainPoints) > 1 Then For i = PointHit To UBound(MainPoints) - 1 MainPoints(i).X = MainPoints(i + 1).X MainPoints(i).Y = MainPoints(i + 1).Y Next i ReDim Preserve MainPoints(1 To UBound(MainPoints) - 1) PointHit = 0 Else ReDim MainPoints(0 To 0) PointHit = 0 End If ElseIf Not PointHit = 0 Then If mnuSnapToGrid.Checked Then MainPoints(PointHit).X = X - ((X - 150) Mod 300) + 150 MainPoints(PointHit).Y = Y - ((Y - 150) Mod 300) + 150 Else MainPoints(PointHit).X = X MainPoints(PointHit).Y = Y End If End If Draw End Sub Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) If Not PointHit = 0 Then If mnuSnapToGrid.Checked Then MainPoints(PointHit).X = X - ((X - 150) Mod 300) + 150 MainPoints(PointHit).Y = Y - ((Y - 150) Mod 300) + 150 Else MainPoints(PointHit).X = X MainPoints(PointHit).Y = Y End If End If Draw End Sub Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, _ X As Single, Y As Single) PointHit = 0 Draw End Sub ' _________________________________ Kirajzoló függvény _________________________________ '/ \ '| Ez a függvény felel a kontrol pontok közötti görbe darabok 10-10 pontjának | '| kiszámításáért, ábrázolásáért, valamint a metszés pontok meghatározásáért, és | '| kirajzolásáért. | '\______________________________________________________________________________________/ Private Sub Draw() Picture2.Cls Dim i As Integer, j As Integer Dim ax As Double, bx As Double, cx As Double, dx As Double Dim ay As Double, by As Double, cy As Double, dy As Double Dim Val11 As Double, Val12 As Double, Val21 As Double, Val22 As Double Dim DerivateInOne As Double, ValueInOne As Double Dim UB As Integer UB = UBound(MainPoints) If mnuShowGrid.Checked Then 'Segéd rács kirajzolása For i = 0 To Picture2.ScaleWidth Step 300 Picture2.Line (i, 0)-(i, Picture2.ScaleHeight), QBColor(7) Next i For i = 0 To Picture2.ScaleHeight Step 300
43
Picture2.Line (0, i)-(Picture2.ScaleWidth, i), QBColor(7) Next i End If 'Az alábbiakban számítjuk ki a kontrol pontok közötti görbeszakaszok 10-10 pontját If UB > 2 Then ReDim AllPoints(1 To 10 * UB) For i = 1 To UB 'Szakasz polinomjainak meghatározása ValueInOne = MainPoints((i Mod UB) + 1).X DerivateInOne = (-MainPoints(i).X + MainPoints(((i + 1) Mod UB) + 1).X) / 2 dx = MainPoints(i).X If i = 1 Then cx = (-MainPoints(UB).X + ValueInOne) / 2 Else cx = (-MainPoints(i - 1).X + ValueInOne) / 2 End If ax = DerivateInOne - 2 * ValueInOne + cx + 2 * dx bx = ValueInOne - cx - dx - ax ValueInOne = MainPoints((i Mod UB) + 1).Y DerivateInOne = (-MainPoints(i).Y + MainPoints(((i + 1) Mod UB) + 1).Y) / 2 dy = MainPoints(i).Y If i = 1 Then cy = (-MainPoints(UB).Y + ValueInOne) / 2 Else cy = (-MainPoints(i - 1).Y + ValueInOne) / 2 End If ay = DerivateInOne - 2 * ValueInOne + cy + 2 * dy by = ValueInOne - cy - dy - ay 'Értékek vissza helyettesítése Val11 = MainPoints(i).X Val12 = MainPoints(i).Y For j = 0 To 10 Val21 = Val11 Val22 = Val12 Val11 = ax * (j / 10) ^ 3 + bx * (j / 10) ^ 2 + cx * (j / 10) + dx Val12 = ay * (j / 10) ^ 3 + by * (j / 10) ^ 2 + cy * (j / 10) + dy If Not j = 0 Then AllPoints(10 * (i - 1) + j).X = Val21 AllPoints(10 * (i - 1) + j).Y = Val22 End If 'Kirajzolás Picture2.Line (Val11, Val12)-(Val21, Val22) Next j If menuShowDerivate.Checked Then 'Deriváltak kirajzolása Picture2.Line (dx - cx / 2, dy - cy / 2)- _ (dx + cx / 2, dy + cy / 2), QBColor(12) End If Next i 'Kettôspontok számítása. ReDim Crossings(0 To 0) SBar.Panels(1).Text = "" Picture2.FillColor = QBColor(12) For i = 1 To 10 * UB If mnuShowAllPoints.Checked Then _ Picture2.Circle (AllPoints(i).X, AllPoints(i).Y), 30, QBColor(12) ax = AllPoints(i Mod 10 * UB + 1).X - AllPoints(i).X ay = AllPoints(i Mod 10 * UB + 1).Y - AllPoints(i).Y For j = 1 To i - 2 bx = AllPoints(j).X - AllPoints(j Mod 10 * UB + 1).X by = AllPoints(j).Y - AllPoints(j Mod 10 * UB + 1).Y cx = AllPoints(j).X - AllPoints(i).X cy = AllPoints(j).Y - AllPoints(i).Y dx = ax * by - ay * bx 'determinant If Not dx = 0 Then Val11 = (cx * by - bx * cy) / dx Val12 = (ax * cy - ay * cx) / dx If Val11 < 1 And Val12 < 1 And Val11 > 0 And Val12 > 0 Then ReDim Preserve Crossings(0 To UBound(Crossings) + 1) Crossings(UBound(Crossings)).X = Val11 * ax + AllPoints(i).X Crossings(UBound(Crossings)).Y = Val11 * ay + AllPoints(i).Y Crossings(UBound(Crossings)).Lines(1) = i
44
Crossings(UBound(Crossings)).Lines(2) = j If Not (AllPoints(i).Crossing = 0 And AllPoints(j).Crossing = 0) Then Picture2.FillStyle = vbSolid Picture2.DrawStyle = vbInvisible SBar.Panels(1).Text = "ERROR: Keep intersection points " + _ "a bit further from eachother or " + _ "add a controll point between them!" End If AllPoints(i).Crossing = UBound(Crossings) AllPoints(j).Crossing = UBound(Crossings) AllPoints((i + UBound(AllPoints) - 2) _ Mod UBound(AllPoints) + 1).Crossing = UBound(Crossings) AllPoints((j + UBound(AllPoints) - 2) _ Mod UBound(AllPoints) + 1).Crossing = UBound(Crossings) AllPoints(i Mod UBound(AllPoints) + 1).Crossing = UBound(Crossings) AllPoints(j Mod UBound(AllPoints) + 1).Crossing = UBound(Crossings) If mnuShowIntersect.Checked Then 'Kirajzolás Picture2.Circle (Crossings(UBound(Crossings)).X, _ Crossings(UBound(Crossings)).Y), 50, QBColor(12) End If Picture2.FillStyle = vbInvisible Picture2.DrawStyle = vbSolid End If End If Next j Next i Else ReDim AllPoints(0 To 0) End If 'Kontrol pontok rajzolása Picture2.FillStyle = vbSolid Picture2.DrawStyle = vbInvisible For i = 1 To UBound(MainPoints) If PointHit = i Then Picture2.FillColor = QBColor(10) Else Picture2.FillColor = QBColor(9) End If Picture2.Circle (MainPoints(i).X, MainPoints(i).Y), 50 If mnuShowNod.Checked Then Picture2.Print i Next i Picture2.FillStyle = vbInvisible Picture2.DrawStyle = vbSolid Picture1.PaintPicture Picture2.Image, 0, 0 End Sub
Form2.frm VERSION 5.00 Begin VB.Form Form2 Caption = "Form2" ClientHeight = 6600 ClientLeft = 60 ClientTop = 450 ClientWidth = 10860 FillColor = &H0000C000& LinkTopic = "Form2" ScaleHeight = 6600 ScaleWidth = 10860 StartUpPosition = 3 'Windows Default Begin VB.CommandButton Command3 Caption = "Command3" Height = 255 Index = 1 Left = 240 TabIndex = 5 Top = 240 Width = 255 End Begin VB.PictureBox Picture2 Appearance = 0 'Flat AutoRedraw = -1 'True BackColor = &H80000005&
45
ForeColor Height Left ScaleHeight ScaleWidth TabIndex Top Visible Width
= = = = = = = = =
&H80000008& 3135 6120 3105 4185 1 480 0 'False 4215
End Begin VB.PictureBox Picture1 Appearance = 0 'Flat BackColor = &H80000005& ForeColor = &H80000008& Height = 3855 Left = 0 ScaleHeight = 3825 ScaleWidth = 5625 TabIndex = 0 Top = 0 Width = 5655 Begin VB.CommandButton Command6 Caption = "Command6" Height = 255 Left = 960 TabIndex = 10 Top = 0 Width = 255 End Begin VB.CommandButton Command5 Caption = "Command5" Height = 255 Left = 720 TabIndex = 9 Top = 0 Width = 255 End Begin VB.CommandButton Command4 Caption = "Command4" Height = 255 Left = 480 TabIndex = 8 Top = 0 Width = 255 End Begin VB.CommandButton Command3 Caption = "Command3" Height = 255 Index = 3 Left = 240 TabIndex = 7 Top = 720 Width = 255 End Begin VB.CommandButton Command3 Caption = "Command3" Height = 255 Index = 2 Left = 480 TabIndex = 6 Top = 480 Width = 255 End Begin VB.CommandButton Command3 Caption = "Command3" Height = 255 Index = 0 Left = 0 TabIndex = 4 Top = 480 Width = 255 End Begin VB.CommandButton Command2 Caption = "Command2" Height = 255 Left = 240 TabIndex = 3
46
Top = Width = End Begin VB.CommandButton Caption = Height = Left = TabIndex = Top = Width = End
0 255 Command1 "Command1" 255 0 2 0 255
End End Attribute VB_Name = "Form2" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Dim DL As Boolean Dim PopX As Single Dim PopY As Single Private Sub Command1_Click() Factor = Factor - 1 fresh End Sub Private Sub Command2_Click() Factor = Factor + 1 fresh End Sub
Private Sub Command3_Click(Index As Integer) Select Case Index Case 0 PoX = PoX - 100 Case 1 PoY = PoY - 100 Case 2 PoX = PoX + 100 Case 3 PoY = PoY + 100 End Select Form_Resize End Sub Private Sub Command4_Click() LetGo = True End Sub Private Sub Command5_Click() DL = Not DL End Sub Private Sub Command6_Click() SavePicture Picture2.Image, "E:/test/P3.bmp" Stop End Sub Private Sub Form_Load() Factor = 1 Me.Width = 20000 Me.Height = 14000 End Sub Private Sub Form_Paint() fresh End Sub Private Sub Form_Resize() Picture1.Width = Me.ScaleWidth - PoX Picture1.Height = Me.ScaleHeight - PoY If Picture2.Width < Picture1.Width Then Picture2.Width = Me.ScaleWidth - PoX
47
If Picture2.Height < Picture1.Height Then Picture2.Height = Me.ScaleHeight - PoY fresh End Sub Public Sub fresh(Optional X As Single = -100, Optional Y As Single = -100) Form2.Picture2.Cls Dim i As Integer, k As Integer, j As Integer Dim Pt(1 To 3) As Points Dim Pt2(1 To 3) As Points Dim pt3 As MeshVertex For i = 1 To UBound(MeshFaces) If MeshFaces(i).active Then MeshFaces(i).MidPoint.X = (MeshVertexs(MeshFaces(i).Vertexes(1)).X + _ MeshVertexs(MeshFaces(i).Vertexes(2)).X + _ MeshVertexs(MeshFaces(i).Vertexes(3)).X) / 3 MeshFaces(i).MidPoint.Y = (MeshVertexs(MeshFaces(i).Vertexes(1)).Y + _ MeshVertexs(MeshFaces(i).Vertexes(2)).Y + _ MeshVertexs(MeshFaces(i).Vertexes(3)).Y) / 3 End If Next i For i = 1 To UBound(MeshVertexs) If Abs(MeshVertexs(i).X * Factor - X) < 30 And _ Abs(MeshVertexs(i).Y * Factor - Y) < 30 Or i = OUTSIDER Then Picture2.FillStyle = vbSolid Picture2.FillColor = QBColor(8 + MeshVertexs(i).CFV) Picture2.Circle (MeshFaces(MeshVertexs(i).CFace).MidPoint.X * Factor, _ MeshFaces(MeshVertexs(i).CFace).MidPoint.Y * Factor), 40 Picture2.FillColor = QBColor(12) Picture2.Circle (MeshVertexs(i).X * Factor, MeshVertexs(i).Y * Factor), 40 Picture2.Print i End If Picture2.Circle (MeshVertexs(i).X * Factor, MeshVertexs(i).Y * Factor), 40 Picture2.FillStyle = vbTransparent Picture2.FillColor = QBColor(0) Next i Dim pri As Boolean For i = 1 To UBound(MeshFaces) If MeshFaces(i).active Then Pt(1).X = MeshVertexs(MeshFaces(i).Vertexes(1)).X Pt(1).Y = MeshVertexs(MeshFaces(i).Vertexes(1)).Y Pt(2).X = MeshVertexs(MeshFaces(i).Vertexes(2)).X Pt(2).Y = MeshVertexs(MeshFaces(i).Vertexes(2)).Y Pt(3).X = MeshVertexs(MeshFaces(i).Vertexes(3)).X Pt(3).Y = MeshVertexs(MeshFaces(i).Vertexes(3)).Y Picture2.Line (Pt(1).X * Factor, Pt(1).Y * Factor)- _ (Pt(2).X * Factor, Pt(2).Y * Factor) Picture2.Line (Pt(3).X * Factor, Pt(3).Y * Factor)- _ (Pt(2).X * Factor, Pt(2).Y * Factor) Picture2.Line (Pt(1).X * Factor, Pt(1).Y * Factor)- _ (Pt(3).X * Factor, Pt(3).Y * Factor) If Abs(MeshFaces(i).MidPoint.X * Factor - X) < 100 And _ Abs(MeshFaces(i).MidPoint.Y * Factor - Y) < 100 Then pri = True Picture2.DrawWidth = 2 Picture2.ForeColor = QBColor(13) End If If MeshFaces(i).OnCurve(3) Then Picture2.DrawWidth = 2 Picture2.ForeColor = QBColor(12) Else Picture2.DrawWidth = 1 Picture2.ForeColor = QBColor(0) End If Picture2.Line (Pt(1).X * Factor, Pt(1).Y (Pt(2).X * Factor, Pt(2).Y If MeshFaces(i).OnCurve(1) Then Picture2.DrawWidth = 2 Picture2.ForeColor = QBColor(12) Else Picture2.DrawWidth = 1 Picture2.ForeColor = QBColor(0) End If Picture2.Line (Pt(3).X * Factor, Pt(3).Y (Pt(2).X * Factor, Pt(2).Y
48
* Factor)- _ * Factor)
* Factor)- _ * Factor)
If MeshFaces(i).OnCurve(2) Then Picture2.DrawWidth = 2 Picture2.ForeColor = QBColor(12) Else Picture2.DrawWidth = 1 Picture2.ForeColor = QBColor(0) End If Picture2.Line (Pt(1).X * Factor, Pt(1).Y * Factor)- _ (Pt(3).X * Factor, Pt(3).Y * Factor) Picture2.DrawWidth = 1 Picture2.ForeColor = QBColor(0) If pri Then Picture2.DrawWidth = 1 Picture2.ForeColor = QBColor(12) Picture2.PSet (MeshFaces(i).MidPoint.X * Factor, _ MeshFaces(i).MidPoint.Y * Factor), QBColor(12) Picture2.Print i Picture2.ForeColor = QBColor(0) pri = False Picture2.FillStyle = vbSolid Picture2.FillColor = QBColor(0) Picture2.Circle (MeshFaces(i).MidPoint.X * Factor, _ MeshFaces(i).MidPoint.Y * Factor), 40 Picture2.Print i For j = 1 To 3 Picture2.FillStyle = vbSolid Picture2.FillColor = QBColor(8 + j) If Not MeshFaces(i).FaceOnOSide(j) = 0 Then Picture2.Circle (MeshFaces(MeshFaces(i).FaceOnOSide(j)). _ MidPoint.X * Factor, _ MeshFaces(MeshFaces(i).FaceOnOSide(j)).MidPoint.Y * Factor), 40 If Not MeshFaces(MeshFaces(i).FaceOnOSide(j)). _ Vertexes(MeshFaces(i).Symetric(j)) = 0 Then pt3 = MeshVertexs(MeshFaces(MeshFaces(i).FaceOnOSide(j)) _ .Vertexes(MeshFaces(i).Symetric(j))) Picture2.Circle (pt3.X * Factor, pt3.Y * Factor), 40 End If End If Picture2.Circle (MeshVertexs(MeshFaces(i).Vertexes(j)).X * Factor, _ MeshVertexs(MeshFaces(i).Vertexes(j)).Y * Factor), 40 Next j End If End If Next i Picture2.FillStyle = vbTransparent Dim Curv() As Integer Curv = CurveSet.ReturnCurve(1) Picture2.DrawWidth = 1 If UBound(Curv) > 0 Then For i = 1 To UBound(Curv) If DL Then Picture2.Line (MeshVertexs(Curv(i, 1)).X * Factor, _ MeshVertexs(Curv(i, 1)).Y * Factor)- _ (MeshFaces(Curv(i, 2)).MidPoint.X * Factor, _ MeshFaces(Curv(i, 2)).MidPoint.Y * Factor), QBColor(10) Picture2.Line (MeshVertexs(Curv(i Mod UBound(Curv) + 1, 1)).X * Factor, _ MeshVertexs(Curv(i Mod UBound(Curv) + 1, 1)).Y * Factor)- _ (MeshFaces(Curv(i, 2)).MidPoint.X * Factor, _ MeshFaces(Curv(i, 2)).MidPoint.Y * Factor), QBColor(10) End If If Abs(MeshVertexs(Curv(i, 1)).X * Factor - X) < 30 And _ Abs(MeshVertexs(Curv(i, 1)).Y * Factor - Y) < 30 Then Picture2.Circle (MeshVertexs(Curv(i, 1)).X * Factor, _ MeshVertexs(Curv(i, 1)).Y * Factor), 60, QBColor(12) Picture2.Circle (MeshFaces(Curv(i, 2)).MidPoint.X * Factor, _ MeshFaces(Curv(i, 2)).MidPoint.Y * Factor), 60, QBColor(9) Picture2.Circle _ (MeshVertexs(MeshFaces(Curv(i, 2)).Vertexes(Curv(i, 3))).X * Factor, _ MeshVertexs(MeshFaces(Curv(i, 2)).Vertexes(Curv(i, 3))).Y * Factor), _ 60, QBColor(10) End If Next i End If Picture2.DrawWidth = 1
49
For i = 1 To UBound(MeshCrossings) Picture2.Circle (MeshFaces(MeshCrossings(i).PFace).MidPoint.X * Factor, _ MeshFaces(MeshCrossings(i).PFace).MidPoint.Y * Factor), 50 Next i For i = 1 To UBound(Backroot, 2) If Not Backroot(1, i) = 0 Then Picture2.Line (MeshFaces(Backroot(1, i)).MidPoint.X * Factor, _ MeshFaces(Backroot(1, i)).MidPoint.Y * Factor)- _ (MeshFaces(i).MidPoint.X * Factor, _ MeshFaces(i).MidPoint.Y * Factor), QBColor(2) End If Next i If UBound(Utacska) > 0 Then For i = 1 To UBound(Utacska, 2) - 1 Picture2.Line (MeshFaces(Utacska(1, i)).MidPoint.X * Factor, _ MeshFaces(Utacska(1, i)).MidPoint.Y * Factor)- _ (MeshFaces(Utacska(1, i + 1)).MidPoint.X * Factor, _ MeshFaces(Utacska(1, i + 1)).MidPoint.Y * Factor), QBColor(4) 'Picture2.Print Utacska(3, i) Next i End If Picture1.PaintPicture Picture2.Image, PoX, PoY End Sub Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, _ X As Single, Y As Single) PopX = X PopY = Y End Sub Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) fresh X - PoX, Y - PoY End Sub Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, _ X As Single, Y As Single) PoX = PoX + Int(X - PopX) PoY = PoY + Int(Y - PopY) Form_Resize End Sub
frmOperation.frm VERSION 5.00 Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX" Begin VB.Form frmOperation Caption = "Calculation in progress!" ClientHeight = 945 ClientLeft = 60 ClientTop = 450 ClientWidth = 6360 LinkTopic = "Form3" ScaleHeight = 945 ScaleWidth = 6360 StartUpPosition = 3 'Windows Default Begin MSComctlLib.ProgressBar prgbOperation Height = 375 Left = 120 TabIndex = 1 Top = 480 Width = 6135 _ExtentX = 10821 _ExtentY = 661 _Version = 393216 Appearance = 1 Min = 1e-4 Scrolling = 1 End Begin VB.Label lbOperation Caption = "Operation" Height = 255
50
Left TabIndex Top Width End End Attribute Attribute Attribute Attribute Attribute
= = = =
120 0 120 6135
VB_Name = "frmOperation" VB_GlobalNameSpace = False VB_Creatable = False VB_PredeclaredId = True VB_Exposed = False
CalcTau.bas Attribute VB_Name = "CalcTau" Option Explicit Public Function CalculateTau() As Integer Dim i As Integer Dim UBi As Integer Dim Lk() As Integer Dim Vodor() As Integer Dim minLk As Integer, maxLk As Integer Dim RetVal As Integer Dim Carier As Integer UBi = UBound(MeshCrossings) If UBi = 0 Then CalculateTau = 0 Exit Function End If If UBi = 1 Then CalculateTau = -1 Exit Function End If
'Kevés pont esetén nem müködik az algoritmus, ezért 'ezeket az eseteket egyszerüen kiszűrjük.
ReDim Lk(2 To UBi) minLk = 0 maxLk = 0 For i = 2 To UBi Vodor = Dijkstra(MeshCrossings(1).PFace, MeshCrossings(i).PFace) Utacska = Vodor 'Keresünk egy utat a meteszés pontok pozitív 'sík negyedében lévô háromszögek között 'háromszögeken keresztül. Elég egy pontból 'indulva keresni az utakat, mert a hurkolódás 'az ilyen utak homotópia osztályaiból az egész 'számok aditív csoportjába menö homomorfizmusa. '----- Teszteléshez kellet ez a rész ----'Form2.Visible = True 'LetGo = False 'Form2.Caption = "Metszési szám: " + Str$(Vodor(1, 0)) + _ ' " Algebrai metszés: " + Str$(Vodor(2, 0)) 'Form2.fresh 'Do ' DoEvents 'Loop Until LetGo '----------------------------------------Lk(i) = Vodor(2, 0) If minLk > Lk(i) Then minLk = Lk(i) If maxLk < Lk(i) Then maxLk = Lk(i) Next i ReDim Vodor(minLk To maxLk) 'Vödrökbe szortírozzuk az elsö ponthoz képest 'azonos hurkolódásu pontokat Vodor(0) = 1 For i = 2 To UBi Vodor(Lk(i)) = Vodor(Lk(i)) + 1 Next i
51
RetVal = 0 Carier = 0 For i = minLk To maxLk
'Azon vödrök számának meghatározása, melyekre a 'korábbi vödrökben lévô összes elem száma páratlan. Carier = Carier + Vodor(i) If Carier Mod 2 = 1 Then RetVal = RetVal + 1 Next i If Carier Mod 2 = 1 Then CalculateTau = -1 Else CalculateTau = RetVal End Function
Dijkstra.bas Attribute VB_Name = "DijkstraModul" Option Explicit Public Function Dijkstra(A1 As Integer, A2 As Integer) As Integer() Dim RetVal() As Integer Dim visited() As Integer ReDim visited(1 To 3, 0 To UBound(MeshFaces)) 'Honnan jöttünk, melyik irányból, hánylépés alatt ReDim FiFoList(0 To 1, 1 To UBound(MeshFaces)) Dim FiFoFirst(0 To 1) As Integer Dim FiFoLast(0 To 1) As Integer Dim NowProc As Integer, NowAdding As Integer, NowPlace As Integer Dim Weight(1 To 2) As Integer Dim i As Integer FiFoFirst(0) = 1 FiFoFirst(1) = 1 FiFoLast(0) = 1 FiFoList(0, 1) = visited(1, A1) = visited(2, A1) = visited(3, A1) =
A1 0 0 1
'Form2.Visible = True Do If FiFoFirst(0) > FiFoLast(0) Then If FiFoFirst(1) > FiFoLast(1) Then MsgBox "ERROR: No root..." 'Elvileg kell legyen út bármely 'két pont között, tehát ez lehetetlen! End 'Ha mégse, akkor az egész program rosz, úgyhogy kilépünk :) Else NowProc = FiFoList(1, FiFoFirst(1)) 'Ha már csak görbe átlépéssel FiFoFirst(1) = FiFoFirst(1) + 1 'haladhatunk tovább. End If Else NowProc = FiFoList(0, FiFoFirst(0)) 'Ha dörbe átlépés nélkül FiFoFirst(0) = FiFoFirst(0) + 1 'haladhatunk. End If For i = 1 To 3 'Szomszédok vizsgálata NowAdding = MeshFaces(NowProc).FaceOnOSide(i) If Not NowAdding = 0 And visited(1, NowAdding) = 0 Then visited(1, NowAdding) = NowProc visited(2, NowAdding) = i visited(3, NowAdding) = visited(3, NowProc) + 1 If MeshFaces(NowProc).OnCurve(i) Then NowPlace = 1 Else NowPlace = 0 End If FiFoLast(NowPlace) = FiFoLast(NowPlace) + 1 FiFoList(NowPlace, FiFoLast(NowPlace)) = NowAdding 'Backroot = visited 'Form2.fresh 'LetGo = False 'Do 'DoEvents 'Loop Until LetGo End If If NowAdding = A2 Then Exit Do Next i
52
Loop ReDim RetVal(1 To 3, 0 To visited(3, NowAdding)) ' Végül az ut keresô fából kinyerjük az utat. NowProc = NowAdding Weight(1) = 0 Weight(2) = 0 For i = visited(3, NowAdding) To 1 Step -1 RetVal(1, i) = visited(1, NowProc) RetVal(2, i) = visited(2, NowProc) RetVal(3, i) = visited(3, NowProc) If i = 1 Then Exit For If MeshFaces(visited(1, NowProc)).OnCurve(visited(2, NowProc)) Then Weight(1) = Weight(1) + 1 Weight(2) = Weight(2) + _ MeshFaces(visited(1, NowProc)).EdgeWeight(visited(2, NowProc)) End If NowProc = visited(1, NowProc) Next i RetVal(1, 0) = Weight(1) 'Metszés szám RetVal(2, 0) = Weight(2) 'Algebrai metszés szám Dijkstra = RetVal End Function
Globals.bas Attribute VB_Name = "Globals" Option Explicit Public Type Crossing X As Double Y As Double Lines(1 To 2) As Integer Vertex As Integer End Type Public Type MCros Vertex As Integer CPoint(1 To 2) As Integer PFace As Integer End Type Public Type Points X As Double Y As Double Crossing As Integer Vertex As Integer End Type Public Type MeshVertex X As Double Y As Double Z As Double CFace As Integer 'A Face that has this point as vertex CFV As Integer 'Index of vertex in CFace Group As Integer CurvePointID As Integer End Type Public Type MeshFace Vertexes(1 To 3) As Integer MidPoint As Points FaceOnOSide(1 To 3) As Integer Symetric(1 To 3) As Integer 'Relative position of symetric point Group As Integer active As Boolean EdgeWeight(1 To 3) As Integer OnCurve(1 To 3) As Boolean End Type Public MeshVertexs() As MeshVertex Public MeshFaces() As MeshFace
53
Public Public Public Public
MainPoints() As Points AllPoints() As Points Crossings() As Crossing MeshCrossings() As MCros
Public Factor As Single Public LetGo As Boolean Public CurveSet As Curves Public Public Public Public
OUTSIDER As Integer Utacska() As Integer Backroot() As Integer Pos As Integer
Public PoX As Long, PoY As Long
TriangulateModule2.bas Attribute VB_Name = "TriangulateModule" Option Explicit
Public Sub Triangulate() 'Form1.Visible = False Dim UB As Integer Dim i As Integer, j As Integer Dim k As Integer, L As Integer Dim BoundBox(1 To 2) As Points ReDim Preserve MeshCrossings(0 To 0) UB = UBound(AllPoints) frmOperation.lbOperation = "1/5 Triangulate : Genarate basegrid" DoEvents frmOperation.prgbOperation.Max = UB BoundBox(1).X = AllPoints(1).X BoundBox(1).Y = AllPoints(1).Y BoundBox(2).X = AllPoints(1).X BoundBox(2).Y = AllPoints(1).Y For i = 2 To UB If BoundBox(1).X > AllPoints(i).X If BoundBox(1).Y > AllPoints(i).Y If BoundBox(2).X < AllPoints(i).X If BoundBox(2).Y < AllPoints(i).Y Next i BoundBox(1).X = BoundBox(1).X - 300 BoundBox(2).X = BoundBox(2).X + 300 BoundBox(1).Y = BoundBox(1).Y - 300 BoundBox(2).Y = BoundBox(2).Y + 300
Then Then Then Then
BoundBox(1).X BoundBox(1).Y BoundBox(2).X BoundBox(2).Y
= = = =
AllPoints(i).X AllPoints(i).Y AllPoints(i).X AllPoints(i).Y
GenerateGrid BoundBox Dim Pt As MeshVertex Pt.Z = 0 Pt.Group = 1 frmOperation.lbOperation = "2/5 Triangulate : Adding 'corner' points of the curve" DoEvents frmOperation.prgbOperation.Max = UBound(AllPoints) For i = 1 To UBound(AllPoints) 'Az AllPoints Tömb tartalmazza a görbe ,,sarok pontjait'' Pt.X = AllPoints(i).X 'Elso lepesben ezeket vesszük hozzá a háromszögeléshez Pt.Y = AllPoints(i).Y AllPoints(i).Vertex = AddPointToMesh(Pt) 'Az AddPointToMesh feladata megtalálni egy-egy pontot Next i 'tartalmazó háromszöget (élet) és tovább bontani ha 'ha szükséges. Dim vvi As Integer Dim vvj As Integer Dim Coo(1 To 2, 1 To 2) As Integer
54
Dim Dim Dim Dim
IPoint() As Double FaceN As MeshFace MvsC(1 To 2) As Integer CutFace As Integer
Set CurveSet = New Curves LetGo = True frmOperation.lbOperation = "3/5 Triangulate : Adding 'edges' of the curve" DoEvents For i = 1 To UBound(AllPoints) frmOperation.prgbOperation.Value = i DoEvents 'Továbbiakban a hiányzó éleket keressük, j = i Mod UBound(AllPoints) + 1 ' és adjuk hozzá a meglévô háromszögeléshez. vvi = AllPoints(i).Vertex 'i és j az él két végpontjának eredeti indexe vvj = AllPoints(j).Vertex 'vvi és vvj a megfelelô vertex indexek Coo(1, 1) = MeshVertexs(vvi).X Coo(1, 2) = MeshVertexs(vvi).Y Coo(2, 1) = MeshVertexs(vvj).X Coo(2, 2) = MeshVertexs(vvj).Y For j = 1 To UBound(MeshFaces) 'Minden lapra FaceN = MeshFaces(j) If FaceN.active Then For k = 1 To 3 'A lap minden élére 'Az alábbi FindIntersection keresi meg 'két szakasz metszés pontjait. 'Meghívás:FindIntersection(a1,a2,b1,b2) 'Ahol a1,a2 az A szakasz b1,b2 a B 'szakasz végpontjai IPoint = FindIntersection(MeshVertexs(vvi), MeshVertexs(vvj), _ MeshVertexs(FaceN.Vertexes(k Mod 3 + 1)), _ MeshVertexs(FaceN.Vertexes((k + 1) Mod 3 + 1))) If UBound(IPoint) = 2 Then 'Ha van metszéspont: If IPoint(1) > 0 And IPoint(1) < 1 And IPoint(2) > 0 And IPoint(2) < 1 Then Pt.X = Coo(1, 1) * IPoint(1) + Coo(2, 1) * (1 - IPoint(1)) Pt.Y = Coo(1, 2) * IPoint(1) + Coo(2, 2) * (1 - IPoint(1)) Pt.Group = 1 If k = 2 And Not MeshFaces(j).Vertexes(3) = FaceN.Vertexes(3) Then CutFace = MeshFaces(j).FaceOnOSide(2) ElseIf k = 3 And Not MeshFaces(j).Vertexes(1) = FaceN.Vertexes(1) Then CutFace = MeshFaces(j).FaceOnOSide(3) Else CutFace = j End If OUTSIDER = AddPointToMesh(Pt, CutFace, k) 'EZ A RÉSZ CSAK NEKEM KELLET TESZTELÉSHEZ, 'és az OUTSIDER is csak ideiglenesen kellet 'If vvi = 155 Then ' LetGo = False ' Form2.fresh 'End If 'Do ' DoEvents 'Loop Until LetGo End If End If Next k End If Next j Next i Dim Dim Dim Dim Dim Dim Dim Dim
Rend As ButaRend FC As Integer, FS As Integer VN As Integer NowProc As Variant NowAdd As Variant visited() As Integer Weight() As Double W As Double
frmOperation.lbOperation = "4/5 Triangulate : Find new 'edges' of the curve" DoEvents
55
For i = 1 To UBound(AllPoints) 'frmOperation.prgbOperation.Value = i 'DoEvents j = i Mod UBound(AllPoints) + 1 vvi = AllPoints(i).Vertex vvj = AllPoints(j).Vertex Set Rend = New ButaRend ReDim NowProc(0 To 1) ReDim visited(1 To 5, 1 To UBound(MeshVertexs)) 'Honnan jövünk: vertex, face, side, ' lépés szám, Hova megyünk(Másodi körben töltjük ki) ReDim Weight(1 To UBound(MeshVertexs)) NowProc = vvi visited(1, vvi) = -1 Do FC = MeshVertexs(NowProc).CFace FS = MeshVertexs(NowProc).CFV Mod 3 + 1 Do VN = MeshFaces(FC).Vertexes(FS) If VN = 0 Then Exit Do If visited(1, VN) = 0 Then visited(1, VN) = NowProc visited(2, VN) = FC visited(3, VN) = FS Mod 3 + 1 Weight(VN) = Weight(NowProc) + Dist(MeshVertexs(VN).X, _ MeshVertexs(VN).Y, MeshVertexs(NowProc).X, MeshVertexs(NowProc).Y) visited(4, VN) = Rend.AddElement(VN, Weight(VN)) Else W = Weight(NowProc) + Dist(MeshVertexs(VN).X, MeshVertexs(VN).Y, _ MeshVertexs(NowProc).X, MeshVertexs(NowProc).Y) If W < Weight(VN) Then Weight(VN) = W Rend.DeCKey visited(4, VN), W visited(1, VN) = NowProc visited(2, VN) = FC visited(3, VN) = FS Mod 3 + 1 End If End If VN = MeshFaces(FC).FaceOnOSide(FS) If VN = 0 Then Exit Do FS = (MeshFaces(FC).Symetric(FS) + 1) Mod 3 + 1 FC = VN Loop Until FC = MeshVertexs(NowProc).CFace NowProc = Rend.DropFirst Loop Until vvj = NowProc VN = NowProc FC = NowProc Do FC = visited(1, FC) visited(5, FC) = VN VN = FC Loop Until visited(1, FC) = -1 Do FC = visited(5, FC) CurveSet.addVertexAfterID visited(1, FC), visited(2, FC), visited(3, FC) Loop Until visited(5, FC) = 0 Next i 'Találjuk meg a kettôs pontokat! Dim TrackC() As Integer TrackC = CurveSet.ReturnCurve(1) Dim A(1 To 2, 1 To 2) As Double ReDim MeshCrossings(0 To 0) frmOperation.lbOperation = "5/5 Triangulate : Find double points of the curve" DoEvents frmOperation.prgbOperation.Max = UBound(TrackC) For i = 1 To UBound(TrackC) 'frmOperation.prgbOperation.Value = i 'DoEvents
56
For j = 1 To i - 1 If TrackC(i, 1) = TrackC(j, 1) Then ReDim Preserve MeshCrossings(0 To UBound(MeshCrossings) + 1) A(1, 1) = MeshVertexs(TrackC(i + 1, 1)).X - MeshVertexs(TrackC(i, A(2, 1) = MeshVertexs(TrackC(i + 1, 1)).Y - MeshVertexs(TrackC(i, A(1, 2) = MeshVertexs(TrackC(j + 1, 1)).X - MeshVertexs(TrackC(j, A(2, 2) = MeshVertexs(TrackC(j + 1, 1)).Y - MeshVertexs(TrackC(j,
1)).X 1)).Y 1)).X 1)).Y
MeshCrossings(UBound(MeshCrossings)).Vertex = TrackC(i, 1) If A(1, 1) * A(2, 2) - A(1, 2) * A(2, 1) > 0 Then MeshCrossings(UBound(MeshCrossings)).CPoint(1) = i MeshCrossings(UBound(MeshCrossings)).CPoint(2) = j MeshCrossings(UBound(MeshCrossings)).PFace = TrackC(i, 2) Else MeshCrossings(UBound(MeshCrossings)).CPoint(1) = j MeshCrossings(UBound(MeshCrossings)).CPoint(2) = i MeshCrossings(UBound(MeshCrossings)).PFace = TrackC(j, 2) End If End If Next j Next i 'Form2.Visible = True 'Form2.fresh End Sub
Private Sub SetWeight(Edge() As Integer) MeshFaces(Edge(1)).EdgeWeight(Edge(2)) = MeshFaces(Edge(1)).EdgeWeight(Edge(2)) + 1 MeshFaces(MeshFaces(Edge(1)).FaceOnOSide(Edge(2))).EdgeWeight(MeshFaces(Edge(1)). _ Symetric(Edge(2))) = MeshFaces(MeshFaces(Edge(1)).FaceOnOSide(Edge(2))). _ EdgeWeight(MeshFaces(Edge(1)).Symetric(Edge(2))) - 1 MeshFaces(Edge(1)).OnCurve(Edge(2)) = True MeshFaces(MeshFaces(Edge(1)).FaceOnOSide(Edge(2))). _ OnCurve(MeshFaces(Edge(1)).Symetric(Edge(2))) = True End Sub Public Function FindEdge(i As Integer, j As Integer) As Integer() Dim RetVal(1 To 2) As Integer Dim NFace As Integer RetVal(1) = MeshVertexs(i).CFace RetVal(2) = MeshVertexs(i).CFV Mod 3 + 1 Do If MeshFaces(RetVal(1)).Vertexes(RetVal(2)) = j Then RetVal(2) = RetVal(2) Mod 3 + 1 Exit Do Else NFace = MeshFaces(RetVal(1)).FaceOnOSide(RetVal(2)) RetVal(2) = (MeshFaces(RetVal(1)).Symetric(RetVal(2)) + 1) Mod 3 + 1 RetVal(1) = NFace End If DoEvents Loop FindEdge = RetVal End Function Private Function AddPointToMesh(Pt As MeshVertex, Optional Fac As Integer = 0, _ Optional ZeroV As Integer = 0) As Integer Dim AffCoords() As Double Dim CFace As Integer Dim j As Integer Dim Epsilon As Double Epsilon = 0.01 Pt.X = Int(Pt.X) Pt.Y = Int(Pt.Y) Pt.Z = Int(Pt.Z) If Fac = 0 Then For CFace = 1 To UBound(MeshFaces) If MeshFaces(CFace).active Then AffCoords = FindAffKoord(MeshFaces(CFace), Pt)
'Felírjuk affin koordinátákkal '3szog pontjaiban az adott pontot If AffCoords(1) >= 0 And AffCoords(2) >= 0 And AffCoords(3) >= 0 Then Exit For
57
End If 'Ha benne van a pont a 3szogben kilépünk Next CFace Else CFace = Fac 'Ha elôre megadták a lapot, nem kell keresni AffCoords = FindAffKoord(MeshFaces(CFace), Pt) End If Dim k As Integer, L As Integer 'Elsô eset: ha csúccsal van dolgunk. If (AffCoords(1) >= (1 - Epsilon) Or AffCoords(2) >= (1 - Epsilon) Or _ AffCoords(3) >= (1 - Epsilon)) Then For k = 1 To 3 If AffCoords(k) >= (1 - Epsilon) Then AddPointToMesh = MeshFaces(CFace).Vertexes(k) Exit Function End If Next k Else ReDim Preserve MeshVertexs(1 To UBound(MeshVertexs) + 1) MeshVertexs(UBound(MeshVertexs)) = Pt ReDim Preserve MeshFaces(1 To UBound(MeshFaces) + 2) Dim Mf(1 To 2) As MeshFace Dim CFace2 As Integer, CFace3 As Integer, CFace4 As Integer 'Itt dôl el, hogy élen vagyunk-e! Ha elôre megadtuk az élet, 'akkor ehez ragaszkodunk. If AffCoords(1) <= Epsilon Or AffCoords(2) <= Epsilon Or _ AffCoords(3) <= Epsilon Or Not ZeroV = 0 Then Mf(1) = MeshFaces(CFace) Dim ZeroVertex(1 To 2) As Integer If ZeroV = 0 Then For k = 1 To 3 If AffCoords(k) <= Epsilon Then 'Megkeressük az élet ZeroVertex(1) = k Exit For End If Next k Else ZeroVertex(1) = ZeroV 'Ha meg volt adva, nem keresünk End If CFace2 = MeshFaces(CFace).FaceOnOSide(ZeroVertex(1)) Mf(2) = MeshFaces(CFace2) ZeroVertex(2) = Mf(1).Symetric(ZeroVertex(1)) 'Itt másoljuk le a két kérdéses háromszöget MeshFaces(UBound(MeshFaces) - 1) = Mf(1) MeshFaces(UBound(MeshFaces)) = Mf(2) 'Alább pedig módosítjuk a szükséges pointereket CFace3 = UBound(MeshFaces) - 1 CFace4 = UBound(MeshFaces) If MeshVertexs(MeshFaces(CFace).Vertexes((ZeroVertex(1) + 1) Mod 3 + 1)) _ .CFace = CFace Then _ MeshVertexs(MeshFaces(CFace).Vertexes((ZeroVertex(1) + 1) Mod 3 + 1)) _ .CFace = CFace3 If MeshVertexs(MeshFaces(CFace2).Vertexes((ZeroVertex(2) + 1) Mod 3 + 1)) _ .CFace = CFace2 Then _ MeshVertexs(MeshFaces(CFace2).Vertexes((ZeroVertex(2) + 1) Mod 3 + 1)) _ .CFace = CFace4 If MeshFaces(CFace).OnCurve(ZeroVertex(1) Mod 3 + 1) Then _ CurveSet.CorrectEdge CFace, CFace3, ZeroVertex(1) Mod 3 + 1 If MeshFaces(CFace2).OnCurve(ZeroVertex(2) Mod 3 + 1) Then _ CurveSet.CorrectEdge CFace2, CFace4, ZeroVertex(2) Mod 3 + 1 MeshFaces(CFace3).Vertexes(ZeroVertex(1) Mod 3 + 1) = UBound(MeshVertexs) MeshFaces(CFace4).Vertexes(ZeroVertex(2) Mod 3 + 1) = UBound(MeshVertexs) MeshFaces(CFace).Vertexes((ZeroVertex(1) + 1) Mod 3 + 1) = UBound(MeshVertexs) MeshFaces(CFace2).Vertexes((ZeroVertex(2) + 1) Mod 3 + 1) = UBound(MeshVertexs) MeshFaces(CFace).OnCurve(ZeroVertex(1) Mod 3 + 1) = False MeshFaces(CFace2).OnCurve(ZeroVertex(2) Mod 3 + 1) = False MeshFaces(CFace3).OnCurve((ZeroVertex(1) + 1) Mod 3 + 1) = False MeshFaces(CFace4).OnCurve((ZeroVertex(2) + 1) Mod 3 + 1) = False MeshFaces(CFace).EdgeWeight(ZeroVertex(1) Mod 3 + 1) = 0
58
MeshFaces(CFace2).EdgeWeight(ZeroVertex(2) Mod 3 + 1) = 0 MeshFaces(CFace3).EdgeWeight((ZeroVertex(1) + 1) Mod 3 + 1) = 0 MeshFaces(CFace4).EdgeWeight((ZeroVertex(2) + 1) Mod 3 + 1) = 0 MeshVertexs(UBound(MeshVertexs)).CFace = CFace MeshVertexs(UBound(MeshVertexs)).CFV = (ZeroVertex(1) + 1) Mod 3 + 1 MeshFaces(CFace).FaceOnOSide(ZeroVertex(1)) = CFace4 MeshFaces(CFace4).FaceOnOSide(ZeroVertex(2)) = CFace MeshFaces(CFace2).FaceOnOSide(ZeroVertex(2)) = CFace3 MeshFaces(CFace3).FaceOnOSide(ZeroVertex(1)) = CFace2 MeshFaces(CFace).FaceOnOSide(ZeroVertex(1) Mod 3 + 1) = CFace3 MeshFaces(CFace3).FaceOnOSide((ZeroVertex(1) + 1) Mod 3 + 1) = CFace MeshFaces(CFace2).FaceOnOSide(ZeroVertex(2) Mod 3 + 1) = CFace4 MeshFaces(CFace4).FaceOnOSide((ZeroVertex(2) + 1) Mod 3 + 1) = CFace2 MeshFaces(MeshFaces(CFace3).FaceOnOSide(ZeroVertex(1) Mod .FaceOnOSide(MeshFaces(CFace3).Symetric(ZeroVertex(1) CFace3 MeshFaces(MeshFaces(CFace4).FaceOnOSide(ZeroVertex(2) Mod .FaceOnOSide(MeshFaces(CFace4).Symetric(ZeroVertex(2) CFace4
3 + 1)) _ Mod 3 + 1)) = _ 3 + 1)) _ Mod 3 + 1)) = _
MeshFaces(CFace).Symetric(ZeroVertex(1) Mod 3 + 1) = _ (ZeroVertex(1) + 1) MeshFaces(CFace3).Symetric((ZeroVertex(1) + 1) Mod 3 + 1) = ZeroVertex(1) Mod 3 MeshFaces(CFace4).Symetric((ZeroVertex(2) + 1) Mod 3 + 1) = ZeroVertex(2) Mod 3 MeshFaces(CFace2).Symetric(ZeroVertex(2) Mod 3 + 1) = _ (ZeroVertex(2) + 1)
Mod 3 + 1 _ + 1 _ + 1 Mod 3 + 1
'Ez az if rész görbe keresésre van If MeshFaces(CFace).OnCurve(ZeroVertex(1)) Then Dim Face As Integer Dim Side As Integer Dim Id As Integer If MeshFaces(CFace).EdgeWeight(ZeroVertex(1)) = 1 Then Face = CFace3 Side = ZeroVertex(1) Id = MeshVertexs(MeshFaces(CFace).Vertexes(Side Mod 3 + 1)).CurvePointID Else Face = CFace4 Side = ZeroVertex(2) Id = MeshVertexs(MeshFaces(CFace2).Vertexes(Side Mod 3 + 1)).CurvePointID End If CurveSet.addVertexAfterID UBound(MeshVertexs), Face, Side, Id End If Else 'Második eset, ha lap belsejében vagyunk Mf(1) = MeshFaces(CFace) MeshFaces(UBound(MeshFaces) - 1) = Mf(1) 'Másolás MeshFaces(UBound(MeshFaces)) = Mf(1) 'Megfelelô adatok módosítása If MeshVertexs(MeshFaces(CFace).Vertexes(1)).CFace = CFace Then _ MeshVertexs(MeshFaces(CFace).Vertexes(1)).CFace = UBound(MeshFaces) MeshFaces(CFace).Vertexes(1) = UBound(MeshVertexs) MeshFaces(UBound(MeshFaces) - 1).Vertexes(2) = UBound(MeshVertexs) MeshFaces(UBound(MeshFaces)).Vertexes(3) = UBound(MeshVertexs) MeshVertexs(UBound(MeshVertexs)).CFace = CFace MeshVertexs(UBound(MeshVertexs)).CFV = 1 MeshFaces(CFace).FaceOnOSide(2) = UBound(MeshFaces) - 1 MeshFaces(CFace).FaceOnOSide(3) = UBound(MeshFaces) MeshFaces(UBound(MeshFaces) - 1).FaceOnOSide(1) = CFace MeshFaces(UBound(MeshFaces) - 1).FaceOnOSide(3) = UBound(MeshFaces) MeshFaces(UBound(MeshFaces)).FaceOnOSide(1) = CFace MeshFaces(UBound(MeshFaces)).FaceOnOSide(2) = UBound(MeshFaces) - 1 MeshFaces(CFace).Symetric(2) = 1 MeshFaces(CFace).Symetric(3) = 1
59
MeshFaces(UBound(MeshFaces) - 1).Symetric(1) = 2 MeshFaces(UBound(MeshFaces) - 1).Symetric(3) = 2 MeshFaces(UBound(MeshFaces)).Symetric(1) = 3 MeshFaces(UBound(MeshFaces)).Symetric(2) = 3 If Not MeshFaces(UBound(MeshFaces) - 1).FaceOnOSide(2) = 0 Then _ MeshFaces(MeshFaces(UBound(MeshFaces) - 1).FaceOnOSide(2)). _ FaceOnOSide(MeshFaces(UBound(MeshFaces) - 1).Symetric(2)) = _ UBound(MeshFaces) - 1 If Not MeshFaces(UBound(MeshFaces)).FaceOnOSide(3) = 0 Then _ MeshFaces(MeshFaces(UBound(MeshFaces)).FaceOnOSide(3)). _ FaceOnOSide(MeshFaces(UBound(MeshFaces)).Symetric(3)) = _ UBound(MeshFaces) End If End If AddPointToMesh = UBound(MeshVertexs) End Function 'Felírás affinkoordinátákban Private Function FindAffKoord(Face As MeshFace, Point As MeshVertex) As Double() Dim det As Double Dim RetVal(1 To 3) As Double det = MeshVertexs(Face.Vertexes(1)).X * MeshVertexs(Face.Vertexes(2)).Y + _ MeshVertexs(Face.Vertexes(2)).X * MeshVertexs(Face.Vertexes(3)).Y + _ MeshVertexs(Face.Vertexes(3)).X * MeshVertexs(Face.Vertexes(1)).Y - _ MeshVertexs(Face.Vertexes(1)).X * MeshVertexs(Face.Vertexes(3)).Y - _ MeshVertexs(Face.Vertexes(3)).X * MeshVertexs(Face.Vertexes(2)).Y - _ MeshVertexs(Face.Vertexes(2)).X * MeshVertexs(Face.Vertexes(1)).Y If det = 0 Then 'Ha a determináns nulla, akkor nem lehet RetVal(1) = -1 'ilyen felírást készíteni. RetVal(2) = -1 'Ilyenkor a 3 pont egy egyenesen, elvileg RetVal(3) = -1 'ilyen nem is jöhet amúgy létre FindAffKoord = RetVal Exit Function End If RetVal(1) = Point.X MeshVertexs(Face.Vertexes(2)).X MeshVertexs(Face.Vertexes(3)).X Point.X MeshVertexs(Face.Vertexes(3)).X MeshVertexs(Face.Vertexes(2)).X
* * * * * *
MeshVertexs(Face.Vertexes(2)).Y MeshVertexs(Face.Vertexes(3)).Y Point.Y - _ MeshVertexs(Face.Vertexes(3)).Y MeshVertexs(Face.Vertexes(2)).Y Point.Y
RetVal(2) = MeshVertexs(Face.Vertexes(1)).X Point.X MeshVertexs(Face.Vertexes(3)).X MeshVertexs(Face.Vertexes(1)).X MeshVertexs(Face.Vertexes(3)).X Point.X
* * * * * *
Point.Y + _ MeshVertexs(Face.Vertexes(3)).Y + _ MeshVertexs(Face.Vertexes(1)).Y - _ MeshVertexs(Face.Vertexes(3)).Y - _ Point.Y - _ MeshVertexs(Face.Vertexes(1)).Y
RetVal(3) = MeshVertexs(Face.Vertexes(1)).X MeshVertexs(Face.Vertexes(2)).X Point.X MeshVertexs(Face.Vertexes(1)).X Point.X MeshVertexs(Face.Vertexes(2)).X
* * * * * *
MeshVertexs(Face.Vertexes(2)).Y + _ Point.Y + _ MeshVertexs(Face.Vertexes(1)).Y - _ Point.Y - _ MeshVertexs(Face.Vertexes(2)).Y - _ MeshVertexs(Face.Vertexes(1)).Y
+ _ + _ - _ - _
RetVal(1) = RetVal(1) / det RetVal(2) = RetVal(2) / det RetVal(3) = RetVal(3) / det FindAffKoord = RetVal End Function 'Távolság függvény Public Function Dist(ax As Double, ay As Double, bx As Double, by As Double) As Double Dist = Sqr((ax - bx) ^ 2 + (ay - by) ^ 2) End Function Private Dim Dim Dim Dim
Sub GenerateGrid(BoundBox() As Points) i As Integer, j As Integer xsp As Integer, ysp As Integer t As Double, s As Double Id As Integer
60
xsp = 7 ysp = 7 ReDim MeshVertexs(1 To (xsp + 3) * (ysp + 3)) ReDim MeshFaces(1 To 2 * (xsp + 3) * (ysp + 3)) For i = 0 To xsp + 2 For j = 0 To ysp + 2 Id = i + (xsp + 3) * j + 1 t = (i - 1) / xsp s = (j - 1) / ysp MeshVertexs(Id).X = Int(BoundBox(1).X * t + MeshVertexs(Id).Y = Int(BoundBox(1).Y * s + MeshVertexs(Id).Group = 1 If i = 0 And Not j = ysp + 2 Then MeshVertexs(Id).CFace = 2 * Id - 1 MeshVertexs(Id).CFV = 1 ElseIf j = 0 Then MeshVertexs(Id).CFace = 2 * Id - 2 MeshVertexs(Id).CFV = 3 ElseIf j = ysp + 2 And Not i = xsp + 2 Then MeshVertexs(Id).CFace = 2 * (Id - xsp MeshVertexs(Id).CFV = 2 ElseIf i = xsp + 2 Then MeshVertexs(Id).CFace = 2 * (Id - xsp MeshVertexs(Id).CFV = 2 Else MeshVertexs(Id).CFace = 2 * Id MeshVertexs(Id).CFV = 1 End If Next j Next i
(1 - t) * BoundBox(2).X) (1 - s) * BoundBox(2).Y)
3) - 1 3) - 2
For i = 0 To xsp + 1 For j = 0 To ysp + 1 Id = i + (xsp + 3) * j + 1 MeshFaces(2 * Id).Vertexes(1) = Id MeshFaces(2 * Id).Vertexes(2) = Id + xsp + 4 MeshFaces(2 * Id).Vertexes(3) = Id + 1 MeshFaces(2 * Id).Group = 1 MeshFaces(2 * Id).FaceOnOSide(1) = (2 * Id + 1) * Sgn(xsp + 1 - i) MeshFaces(2 * Id).Symetric(1) = 3 * Sgn(xsp + 1 - i) If Not j = 0 Then MeshFaces(2 * Id).FaceOnOSide(2) = 2 * (Id - xsp - 3) - 1 MeshFaces(2 * Id).Symetric(2) = 1 Else MeshFaces(2 * Id).FaceOnOSide(2) = 0 MeshFaces(2 * Id).Symetric(2) = 0 End If MeshFaces(2 * Id).FaceOnOSide(3) = 2 * Id - 1 MeshFaces(2 * Id).Symetric(3) = 2 MeshFaces(2 MeshFaces(2 MeshFaces(2 MeshFaces(2
* * * *
Id Id Id Id
-
1).Vertexes(1) = Id 1).Vertexes(2) = Id + xsp + 3 1).Vertexes(3) = Id + xsp + 4 1).Group = 1
If Not j = ysp + 2 Then MeshFaces(2 * Id - 1).FaceOnOSide(1) = 2 * (Id + xsp + 3) MeshFaces(2 * Id - 1).Symetric(1) = 2 Else MeshFaces(2 * Id - 1).FaceOnOSide(1) = 0 MeshFaces(2 * Id - 1).Symetric(1) = 0 End If MeshFaces(2 * Id - 1).FaceOnOSide(2) = (2 * Id) MeshFaces(2 * Id - 1).Symetric(2) = 3 MeshFaces(2 * Id - 1).FaceOnOSide(3) = (2 * Id - 2) * Sgn(i) MeshFaces(2 * Id - 1).Symetric(3) = 1 * Sgn(i) MeshFaces(2 * Id).active = True MeshFaces(2 * Id - 1).active = True Next j Next i 'For i = 1 To UBound(MeshFaces) ' If MeshFaces(i).active Then
61
' For j = 1 To 3 ' If Not MeshFaces(i).FaceOnOSide(j) = 0 Then ' If MeshFaces(MeshFaces(i).FaceOnOSide(j)).active = False Then ' DoEvents ' End If ' End If ' Next j ' End If 'Next i End Sub Public Function FindIntersection _ (A As MeshVertex, b As MeshVertex, c As MeshVertex, d As MeshVertex) As Double() Dim M(1 To 3, 1 To 2) As Double 'Metszéspont keresés Dim det As Double Dim RetVal(0 To 2) As Double M(1, 1) = A.X - b.X M(1, 2) = A.Y - b.Y M(2, 1) = c.X - d.X M(2, 2) = c.Y - d.Y M(3, 1) = d.X - b.X M(3, 2) = d.Y - b.Y det = M(1, 1) * M(2, 2) - M(1, 2) * M(2, 1) If det = 0 Then Dim RV(0 To 0) As Double FindIntersection = RV Exit Function End If RetVal(0) = det RetVal(1) = (M(3, 1) * M(2, 2) - M(3, 2) * M(2, 1)) / det RetVal(2) = -(M(1, 1) * M(3, 2) - M(1, 2) * M(3, 1)) / det FindIntersection = RetVal End Function
ButaRend.cls VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "ButaRend" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit Private Type CrsT Data As Variant Key As Double Next As Integer Prev As Integer End Type Dim Keeper() As CrsT Private Sub Class_Initialize() ReDim Keeper(0 To 0) End Sub Public Function AddElement(Data As Variant, Key As Double) As Integer Dim i As Integer, j As Integer If Keeper(0).Next = 0 Then ReDim Keeper(0 To 1) Keeper(0).Next = 1 Keeper(1).Data = Data Keeper(1).Key = Key Keeper(1).Next = 0 Keeper(1).Prev = 0 AddElement = 1 Else ReDim Preserve Keeper(0 To UBound(Keeper) + 1)
62
Keeper(UBound(Keeper)).Data = Data Keeper(UBound(Keeper)).Key = Key i = 0 Do j = i i = Keeper(i).Next Loop Until Keeper(i).Key > Key Or i = 0 Keeper(UBound(Keeper)).Next = i Keeper(UBound(Keeper)).Prev = j Keeper(i).Prev = UBound(Keeper) Keeper(j).Next = UBound(Keeper) AddElement = UBound(Keeper) End If End Function Public Sub DeCKey(Index As Integer, Key As Double) Dim i As Integer, j As Integer Keeper(Index).Key = Key If Keeper(Keeper(Index).Prev).Key > Key Then Keeper(Keeper(Index).Prev).Next = Keeper(Index).Next Keeper(Keeper(Index).Next).Prev = Keeper(Index).Prev j = Index Do j = Keeper(j).Prev Loop Until Keeper(j).Key < Key Or j = 0 i = Keeper(j).Next Keeper(Index).Next = i Keeper(Index).Prev = j Keeper(i).Prev = Index Keeper(j).Next = Index End If End Sub Public Function ReturnArray() As Variant() Dim RetVal() As Variant ReDim RetVal(1 To UBound(Keeper)) Dim i As Integer, j As Integer, k As Integer i = 0 For k = 1 To UBound(RetVal) j = i i = Keeper(i).Next RetVal(k) = Keeper(i).Data Next k ReturnArray = RetVal End Function Public Function DropFirst() DropFirst = Keeper(Keeper(0).Next).Data Keeper(0).Next = Keeper(Keeper(0).Next).Next Keeper(Keeper(0).Next).Prev = 0 End Function
Curves.cls VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "Curves" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit Private Type EdgeData Face As Integer Side As Integer End Type
63
Private Type CurveData Vertex As Integer Edge As EdgeData 'Next Edge! Next As Integer Prev As Integer CurveId As Integer End Type Dim CurveStarts() As Integer Dim Curves() As CurveData Private Sub Class_Initialize() ReDim CurveStarts(0 To 0) ReDim Curves(0 To 0) End Sub 'Public Sub BuildUpFromVertexIDList(List() As Integer) ' Dim i As Integer ' Dim CFace As Integer, CVert As Integer, NFace As Integer ' Dim UB As Integer ' UB = UBound(List) ' ' ReDim CurveStarts(1 To 1) ' ReDim Curves(1 To UB) ' CurveStarts(1) = 1 ' Curves(1).CurveId = 1 ' For i = 1 To UB ' Curves(i).Vertex = List(i) ' CFace = MeshVertexs(List(i)).CFace ' CVert = MeshVertexs(List(i)).CFV Mod 3 + 1 ' Do ' Form2.fresh ' Form2.Picture1.Circle (MeshVertexs(List(i)).X * Factor, MeshVertexs(List(i)).Y * Factor), 30 * Factor, QBColor(12) ' Form2.Picture1.Circle (MeshVertexs(List(i + 1)).X * Factor, MeshVertexs(List(i + 1)).Y * Factor), 30 * Factor, QBColor(10) ' Form2.Picture1.Circle (MeshVertexs(MeshFaces(CFace).Vertexes(CVert)).X * Factor, MeshVertexs(MeshFaces(CFace).Vertexes(CVert)).Y * Factor), 30 * Factor, QBColor(9) ' If MeshFaces(CFace).Vertexes(CVert) = List(i Mod UB + 1) Then ' Exit Do ' Else ' NFace = MeshFaces(CFace).FaceOnOSide(CVert) ' CVert = (MeshFaces(CFace).Symetric(CVert) + 1) Mod 3 + 1 ' CFace = NFace ' End If ' Loop ' Curves(i).Edge.Face = CFace ' Curves(i).Edge.Side = CVert Mod 3 + 1 ' Curves(i).Next = i Mod UB + 1 ' Curves(i).Prev = (i + UB - 2) Mod UB + 1 ' Next i 'End Sub Public Sub CorrectEdge(OldFace As Integer, NewFace As Integer, Side As Integer) Dim i As Integer For i = 1 To UBound(Curves) If Curves(i).Edge.Face = OldFace And Curves(i).Edge.Side = Curves(i).Edge.Face = NewFace Next i End Sub Public Function addVertexAfterID(Vertex As Integer, Optional ByVal AfterID As Integer = 0) As Integer Dim UB As Integer Dim Temp As Integer If UBound(CurveStarts) = 0 Then ReDim CurveStarts(1 To 1) ReDim Curves(1 To 1) CurveStarts(1) = 1 Curves(1).CurveId = 1 Curves(1).Next = 1 Curves(1).Prev = 1 UB = 1 Else UB = UBound(Curves) + 1
64
Face
As
Integer,
Side
Side
As
Then
Integer,
ReDim Preserve Curves(1 To UB) If AfterID = 0 Then AfterID = Curves(1).Prev Curves(UB).Prev = AfterID Curves(UB).Next = Curves(AfterID).Next Curves(Curves(AfterID).Next).Prev = UB Curves(AfterID).Next = UB End If Curves(UB).Vertex = Vertex Curves(UB).Edge.Face = Face Curves(UB).Edge.Side = Side MeshFaces(Face).OnCurve(Side) = True MeshFaces(Face).EdgeWeight(Side) = MeshFaces(Face).EdgeWeight(Side) + 1 Temp = MeshFaces(Face).FaceOnOSide(Side) Side = MeshFaces(Face).Symetric(Side) Face = Temp MeshFaces(Face).OnCurve(Side) = True MeshFaces(Face).EdgeWeight(Side) = MeshFaces(Face).EdgeWeight(Side) - 1 addVertexAfterID = UB End Function Public Function ReturnCurve(Id As Integer) As Integer() Dim i As Integer Dim j As Integer Dim k As Integer Dim RetVal() As Integer If UBound(CurveStarts) = 0 Then ReDim RetVal(0 To 0) ReturnCurve = RetVal Exit Function End If i = 0 j = CurveStarts(Id) Do i = i + 1 j = Curves(j).Next Loop Until j = CurveStarts(Id) ReDim RetVal(1 To i, 1 To 3) j = CurveStarts(Id) For k = 1 To i RetVal(k, 1) = Curves(j).Vertex RetVal(k, 2) = Curves(j).Edge.Face RetVal(k, 3) = Curves(j).Edge.Side j = Curves(j).Next Next k ReturnCurve = RetVal End Function
Lippner algoritmus Ennél az algoritmusnál nem közlöm a teljes forráskódot, mer a felület generáló algoritmus forráskódja jelentősen meghaladja terjedelmében ezen dokumentum kereteit. Akit esetleg érdekel, annak el tudom küldeni E-mailben a teljes – közel 130 oldalt kitevő – forráskódot.
Form1.frm VERSION 5.00 Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX" Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX" Begin VB.Form Form1 BackColor = &H00FFFFFF& ClientHeight = 6795 ClientLeft = 165 ClientTop = 855 ClientWidth = 10170
65
LinkTopic = "Form1" ScaleHeight = 6795 ScaleWidth = 10170 StartUpPosition = 3 'Windows Default Begin MSComctlLib.StatusBar StatusBar Align = 2 'Align Bottom Height = 375 Left = 0 TabIndex = 0 Top = 6420 Width = 10170 _ExtentX = 17939 _ExtentY = 661 _Version = 393216 BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} NumPanels = 1 BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} AutoSize = 1 Object.Width = 17410 EndProperty EndProperty End Begin MSComDlg.CommonDialog CD Left = 960 Top = 2520 _ExtentX = 847 _ExtentY = 847 _Version = 393216 End Begin VB.Menu mnu_file Caption = "File" Begin VB.Menu mnu_lin_input Caption = "Line Input" End Begin VB.Menu mnuListInp Caption = "List Input" End Begin VB.Menu mnuGInput Caption = "Garphical Input" End Begin VB.Menu mnuHistory Caption = "History" Begin VB.Menu mnuHistPlace Caption = "HistPlace" Index = 0 End End Begin VB.Menu mnu_sep1 Caption = "-" End Begin VB.Menu mnu_exportTouch Caption = "Export Touch Data" End Begin VB.Menu mnu_exportDTouch Caption = "Export Duplicated Touch Data" End Begin VB.Menu mnu_exportTransversal Caption = "Export Transversal Data" End End Begin VB.Menu mnu_View Caption = "View" Begin VB.Menu mnu_ViewC Caption = "Original Tree" Checked = -1 'True Index = 1 End Begin VB.Menu mnu_ViewC Caption = "Double Switch Tree" Index = 2 End Begin VB.Menu mnu_ViewC Caption = "Original Circles" Index = 3 End Begin VB.Menu mnu_ViewC Caption = "Double Switch "
66
Index End
=
4
End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Dim PX As Single, PY As Single, LastMX As Single, LastMY As Single Private Type MyNode LastActive As Integer pair As Integer Parent As Integer FChild As Integer NoChild As Integer LSibling As Integer RSibling As Integer Depth As Integer side As Boolean MidPoint(1 To 2) As Double Radius As Double PairType As Integer IsOnPlace As Boolean Direction As Double End Type Const Pi = 3.14159265358979 Public inp As String Dim Tree() As MyNode Dim DTree() As MyNode Dim NDTree() As MyNode Dim GoNow As Boolean Dim BVTouch As Boolean Dim BVTransv As Boolean Private Sub Form_KeyPress(KeyAscii As Integer) GoNow = True End Sub '----------------------------------Felhasználói felület----------------------------------Private Sub mnu_lin_input_Click() inp = InputBox("Enter Code", "", "") UpdateHist LoadTree End Sub Private Sub mnuListInp_Click() Dim WaitOK As Boolean CD.ShowOpen Open CD.FileName For Input As #1 CD.ShowSave Open CD.FileName For Output As #2 WaitOK = (MsgBox("Stop at each tree to check?", vbOKCancel) = 2) Do Line Input #1, inp LoadTree StatusBar.Panels(1).Text = inp + " : " + StatusBar.Panels(1).Text Print #2, inp + ":" + Str$(BVTouch) + ":" + Str$(BVTransv) Do GoNow = WaitOK DoEvents Loop Until GoNow = True Loop Until EOF(1) Close #1
67
Close #2 End Sub Private Sub mnuGInput_Click() Load Form2 Form2.Show vbModal UpdateHist LoadTree End Sub Private Sub mnuHistPlace_Click(Index As Integer) inp = mnuHistPlace(Index).Caption LoadTree End Sub Private Sub UpdateHist() Dim i As Integer Dim was As Boolean was = False For i = 1 To 10 If mnuHistPlace(i).Caption = inp Then was = True Next i If Not was Then For i = 10 To 2 Step -1 mnuHistPlace(i).Caption = mnuHistPlace(i - 1).Caption SaveSetting "LipnerCircles", "History", Str$(i), mnuHistPlace(i).Caption Next i mnuHistPlace(1).Caption = inp SaveSetting "LipnerCircles", "History", Str$(1), mnuHistPlace(1).Caption End If End Sub Private Sub mnu_exportTouch_Click() CD.ShowSave save Tree, CD.FileName, False End Sub Private Sub mnu_exportDTouch_Click() CD.ShowSave save NDTree, CD.FileName, True End Sub Private Sub mnu_exportTransversal_Click() CD.ShowSave save DTree, CD.FileName, True End Sub Private Sub Form_GotFocus() If Not UBound(Tree) = 0 Then DrawTree Tree End Sub Private Sub Form_Load() ReDim Tree(0 To 0) ReDim DTree(0 To 0) ReDim NDTree(0 To 0) Dim i As Integer For i = 1 To 10 Load mnuHistPlace(i) mnuHistPlace(i).Caption = GetSetting("LipnerCircles", "History", Str$(i), "0,0") Next i mnuHistPlace(0).Visible = False End Sub Private Sub Form_Paint() If Not UBound(Tree) = 0 Then Draw End Sub Private Sub Form_Resize() If Not UBound(Tree) = 0 Then Draw End Sub Private Sub mnu_ViewC_Click(Index As Integer) Dim i As Integer
68
For i = 1 To 4 mnu_ViewC(i).Checked = False Next i mnu_ViewC(Index).Checked = True Draw End Sub '-------------------------------------Fa/Kör rajzolás----------------------------------Private Sub Draw() If mnu_ViewC(1).Checked If mnu_ViewC(2).Checked If mnu_ViewC(3).Checked If mnu_ViewC(4).Checked End Sub
Then Then Then Then
DrawTree Tree DrawTree DTree DrawCircles Tree DrawCircles DTree
Private Sub DrawTree(LTree() As MyNode) ReDim Verem(0 To UBound(LTree) + 1) As Integer ReDim VerPos(0 To UBound(LTree) + 1) As Integer Dim Actual As Integer, Actual2 As Integer Dim Depth As Integer Dim color As Long Dim indSide As Boolean indSide = TouchRealizable(LTree) Actual = 0 Actual2 = 0 VerPos(0) = 1 Cls Form1.DrawWidth = 1 Form1.DrawStyle = 0 Do If LTree(Actual).FChild = 0 Then If Verem(0) = 0 Then Exit Sub Actual = Verem(Verem(0)) Verem(0) = Verem(0) - 1 Else Actual2 = LTree(Actual).FChild Do Actual2 = LTree(Actual2).LSibling If Actual2 = LTree(Actual).FChild Then Exit Do Verem(0) = Verem(0) + 1 Verem(Verem(0)) = Actual2 Loop Actual = LTree(Actual).FChild End If VerPos(LTree(Actual).Depth) = GetVerPos(LTree(Actual).Depth, VerPos) color = QBColor(Int((Actual + 1) / 2) Mod 15) Form1.DrawStyle = Int((Actual + 1) / 30) If indSide Then Form1.DrawWidth = Abs(LTree(Actual).side) + 1 Line (VerPos(LTree(LTree(Actual).Parent).Depth) * 500, _ 1000 + LTree(LTree(Actual).Parent).Depth * 800)- _ (VerPos(LTree(Actual).Depth) * 500, 1000 + LTree(Actual).Depth * 800), color Print Actual Loop End Sub Private Function GetVerPos(Depth As Integer, VerPos() As Integer) As Integer Dim RetVal As Integer Dim D As Integer RetVal = VerPos(Depth) For D = Depth To UBound(VerPos) If VerPos(D) > VerPos(D - 1) Then RetVal = VerPos(D) If VerPos(D) = 0 Then Exit For Next D GetVerPos = RetVal + 1 End Function Private Dim Dim Dim Dim
Sub DrawCircles(LTree() As MyNode) Pan_x As Integer Pan_y As Integer i As Integer color As Long
69
Pan_x = 5000 Pan_y = 5000 Cls For i = 1 To UBound(LTree) color = QBColor(Int((i + 1) / 2) Mod 15) Circle (Pan_x + LTree(i).MidPoint(1), Pan_y + LTree(i).MidPoint(2)), _ LTree(i).Radius, color Next i End Sub '--------------------------------Általános matematikai függvények---------------------Private Function Dist(X1 As Single, Y1 As Single, X2 As Single, Y2 As Single) As Single Dist = ((X1 - X2) ^ 2 + (Y1 - Y2) ^ 2) ^ (1 / 2) End Function Private Function Min(a As Double, b As Double) As Double If a < b Then Min = a Else Min = b End If End Function '-------------------------------------Fa kezelési eljárások---------------------------Private Function AddChildTree(i, j, LTree() As MyNode) As MyNode() LTree(i).Parent = j If LTree(j).FChild = 0 Then LTree(j).FChild = i LTree(i).LSibling = i LTree(i).RSibling = i Else LTree(i).RSibling = LTree(j).FChild LTree(i).LSibling = LTree(LTree(j).FChild).LSibling LTree(LTree(i).RSibling).LSibling = i LTree(LTree(i).LSibling).RSibling = i End If LTree(j).NoChild = LTree(j).NoChild + 1 AddChildTree = LTree End Function Private Function RemoveChildTree(i, LTree() As MyNode) As MyNode() LTree(LTree(i).Parent).NoChild = LTree(LTree(i).Parent).NoChild - 1 If LTree(i).LSibling = i Then LTree(LTree(i).Parent).FChild = 0 Else If LTree(LTree(i).Parent).FChild = i Then LTree(LTree(i).Parent).FChild = LTree(i).LSibling End If LTree(LTree(i).RSibling).LSibling = LTree(i).LSibling LTree(LTree(i).LSibling).RSibling = LTree(i).RSibling End If RemoveChildTree = LTree End Function 'Az alábbi függvények szolgálnak út keresésre. Az elsô a gyökérig vezeto utat 'keresi meg. A második két tetszôleges elem közöt keres utat a fában. Megeresi 'mindkét pontra a gyökérig vezetô utat, majd megkeresi a két út elsô közös pontját '(alulról számítva) majd össze fűzi a két utat. Private Function RootPath(i, LTree() As MyNode) As Integer() Dim k As Integer Dim RetVal() As Integer ReDim r(0 To UBound(LTree) + 1) As Integer r(0) = 1 r(1) = i Do Until r(r(0)) = 0 r(0) = r(0) + 1 If UBound(LTree) + 1 < r(0) Then ReDim RetVal(0 To 0) As Integer RetVal(0) = 0 RootPath = RetVal Exit Function
70
End If r(r(0)) = LTree(r(r(0) - 1)).Parent Loop ReDim RetVal(1 To r(0)) As Integer For k = 1 To r(0) RetVal(k) = r(k) Next k RootPath = RetVal End Function Private Dim Dim Dim Dim Dim
Function Path(i, j, LTree() As MyNode) As Integer() Ri() As Integer Rj() As Integer RetVal() As Integer k As Integer s As Integer
Ri = RootPath(i, LTree) Rj = RootPath(j, LTree) k = 0 Do If UBound(Ri) - k - 1 > 0 And UBound(Rj) - k - 1 > 0 Then If Ri(UBound(Ri) - k - 1) = Rj(UBound(Rj) - k - 1) Then k = k + 1 Else Exit Do End If Else Exit Do End If Loop ReDim RetVal(1 To UBound(Ri) + UBound(Rj) - 2 * k - 1) As Integer For s = 1 To UBound(Ri) - k RetVal(s) = Ri(s) Next s For s = 1 To UBound(Rj) - k - 1 RetVal(UBound(Ri) - k + s) = Rj(UBound(Rj) - k - s) Next s Path = RetVal End Function 'Az alábbi függvény segítségével különböztetjük meg a kör pár típusokat. Private Function GetPairType(i As Integer, j As Integer, LTree() As MyNode) As Integer If i = 0 Then GetPairType = 0 Else Dim r() As Integer r = Path(i, j, LTree) If Not r(2) = LTree(i).Parent Then GetPairType = 1 'Vertikális pár felsô köre ElseIf Not r(UBound(r) - 1) = LTree(j).Parent Then '(lefele induló út) GetPairType = -1 'Vertikális pár alsó köre Else '(lefele végzödô út) GetPairType = 0 'Horizontális körpár End If '(ha egyik vége sem End If 'lefele halad) End Function '------------------------------------Megvalósíthatóság vizsgálat------------------------Private Dim G = G =
Function TouchRealizable(LTree() As MyNode) As Boolean G() As Integer BuildLinkGraph(LTree) IsBiParite(G)
TouchRealizable = (G(0) = 1) End Function 'Habár normális estben csak egy típusú DoubleSwitch van most mégis 'két különbözô esetet kell megkülönböztetnünk aszeirn, hogy 'a körpár horizontális, vagy vertikális. Az elsô eset kifejezetten
71
'egyszerü, viszont a vertikális esetben meg kell fordítani a 'gyermek-szülô viszonyokat. Private Function DoubleSwitch(LTree() As MyNode) As MyNode() Dim i As Integer, j As Long Dim Switched() As Boolean Dim r() As Integer Dim RetVal() As MyNode Dim Treebound As Integer Treebound = UBound(LTree) RetVal = LTree ReDim Switched(1 To Treebound) As Boolean For i = 1 To Treebound If Not Switched(i) Then j = RetVal(i).pair Switched(i) = True: Switched(j) = True r = Path(i, j, RetVal) If Not r(2) = RetVal(i).Parent Then RetVal = AncestorSwitch(j, i, RetVal) 'Vertikális eset ElseIf Not r(UBound(r) - 1) = RetVal(j).Parent Then RetVal = AncestorSwitch(i, j, RetVal) 'Vertikális eset Else RetVal = NormalSwitch(i, j, RetVal) 'Horizontális eset End If End If Next i For j = 1 To UBound(RetVal) r = RootPath(j, RetVal) If UBound(r) = 0 Then MsgBox "Error!" Else RetVal(j).Depth = UBound(r) End If Next j
'Ellenôrizzük, hogy nincs-e hiba. '(Ez elsôsorban fejlesztés közben 'volt hasznos, mostmár 'törölhetô lenne.)
DoubleSwitch = RetVal End Function Private Function NormalSwitch(i, j, LTree() As MyNode) As MyNode() Dim k As Integer, l As Integer Dim RetVal() As MyNode RetVal = LTree ReDim Preserve RetVal(0 To UBound(LTree) + 2) k = RetVal(i).Parent: l = RetVal(j).Parent RetVal = RemoveChildTree(i, RetVal) RetVal = RemoveChildTree(j, RetVal) RetVal = AddChildTree(UBound(RetVal) - 1, l, RetVal) RetVal = AddChildTree(UBound(RetVal), k, RetVal) RetVal = AddChildTree(i, UBound(RetVal) - 1, RetVal) RetVal = AddChildTree(j, UBound(RetVal), RetVal) RetVal(UBound(RetVal) - 1).pair = UBound(RetVal) RetVal(UBound(RetVal)).pair = UBound(RetVal) - 1 NormalSwitch = RetVal End Function Private Dim Dim Dim Dim
Function AncestorSwitch(i, j, LTree() As MyNode) As MyNode() k As Integer Child As Integer, nextChild As Integer r() As Integer RetVal() As MyNode
RetVal = LTree r = Path(i, j, RetVal) ReDim Preserve RetVal(0 To UBound(RetVal) + 2) If UBound(r) = 2 Then RetVal = RemoveChildTree(i, RetVal) Do Child = RetVal(j).FChild If Not Child = 0 Then RetVal = RemoveChildTree(Child, RetVal)
72
RetVal = AddChildTree(Child, UBound(RetVal) - 1, RetVal) Else Exit Do End If Loop RetVal = AddChildTree(UBound(RetVal) - 1, j, RetVal) RetVal = AddChildTree(UBound(RetVal), UBound(RetVal) - 1, RetVal) RetVal = AddChildTree(i, UBound(RetVal), RetVal) Else For k = 1 To UBound(r) - 1 RetVal = RemoveChildTree(r(k), RetVal) Next k RetVal = AddChildTree(UBound(RetVal) - 1, j, RetVal) RetVal = AddChildTree(r(2), UBound(RetVal) - 1, RetVal) For k = 2 To UBound(r) - 2 RetVal = AddChildTree(r(k + 1), r(k), RetVal) Next k RetVal = AddChildTree(UBound(RetVal), r(UBound(r) - 1), RetVal) RetVal = AddChildTree(i, UBound(RetVal), RetVal) RetVal(UBound(RetVal) - 1).pair = UBound(RetVal) RetVal(UBound(RetVal)).pair = UBound(RetVal) - 1 End If RetVal(UBound(RetVal) - 1).pair = UBound(RetVal) RetVal(UBound(RetVal)).pair = UBound(RetVal) - 1 AncestorSwitch = RetVal End Function 'Alább körpárokra ellenôrizzuk, hogy hurkolódnak-e. Ehhez azt az 'észrevételt alkalmazzuk, hogy körpár pontosan akkor hurkolódik 'ha valamelyik él pár két elemét összekötô úton a másik élpárnak 'pontosan egy éle van rajta. Private Function IsLinked(i, j, LTree() As MyNode) As Boolean Dim Dim Dim Dim
r() As Integer Link As Boolean k As Integer l As Integer
If i = j Or i = LTree(j).pair Or i = 0 Or j = 0 Then IsLinked = False Exit Function End If r = Path(i, LTree(i).pair, LTree) l = LTree(j).pair Link = False For k = 1 To UBound(r) If (r(k) = j Or r(k) = l) Then If k = 1 And LTree(r(k)).Parent = r(k + 1) Then Link = Not Link ElseIf k = UBound(r) And LTree(r(k)).Parent = r(k - 1) Then Link = Not Link ElseIf (LTree(r(k)).Parent = r(k + 1) Or _ LTree(r(k)).Parent = r(k - 1)) Then Link = Not Link End If End If Next k IsLinked = Link End Function 'Hurkolódási gráf felépítése. (Él listával tárolva.) Private Function BuildLinkGraph(LTree() As MyNode) As Integer() Dim i As Integer, j As Integer 'Fa csúcsok Dim k As Integer, l As Integer 'Gráf csúcsok Dim RetVal() As Integer Dim Found() As Integer ReDim RetVal(1 To UBound(LTree) / 2, -1 To UBound(LTree) / 2) As Integer
73
ReDim Found(1 To UBound(LTree)) k = 0 For i = 1 To UBound(LTree) If Found(i) = 0 Then k = k + 1 Found(i) = k Found(LTree(i).pair) = k RetVal(k, -1) = i
'Fapontokhoz tároljuk, hogy melyik gráfpont 'lett belôle gráfpont lett belôle. Tároljuk 'a gráfban az eredeti fa pont indexét For l = 1 To k - 1 'És aki ezt a sor kommentet elsôként j = RetVal(l, -1) 'elolvassa, akkor vendégem egy nutellás pizzára. 'Márpedig a nutellás pizza finom nagyon! If IsLinked(i, j, LTree) Or IsLinked(j, i, LTree) Then RetVal(k, 0) = RetVal(k, 0) + 1 RetVal(l, 0) = RetVal(l, 0) + 1 RetVal(k, RetVal(k, 0)) = l RetVal(l, RetVal(l, 0)) = k End If Next l End If Next i BuildLinkGraph = RetVal End Function 'Gráf kettôszinezése. Private Function IsBiParite(G As Variant) As Integer() Dim RetVal() As Integer Dim Reached() As Integer ReDim RetVal(0 To UBound(G, 1)) As Integer ReDim Reached(0 To UBound(G, 1)) As Integer Dim i As Integer, j As Integer, ComponentSearcher As Integer, Crawl As Integer Reached(0) = 1 Reached(1) = 1 RetVal(1) = 1 ComponentSearcher = 1 Crawl = 1 Do For i = 1 To G(Reached(Crawl), 0) If RetVal(G(Reached(Crawl), i)) = 0 Then RetVal(G(Reached(Crawl), i)) = 3 - RetVal(Reached(Crawl)) Reached(0) = Reached(0) + 1 If Reached(0) > UBound(Reached) Then RetVal(0) = 1 IsBiParite = RetVal Exit Function End If Reached(Reached(0)) = G(Reached(Crawl), i) ElseIf RetVal(G(Reached(Crawl), i)) = 3 - RetVal(Reached(Crawl)) Then Else Dim RV(0 To 0) As Integer RV(0) = 0 IsBiParite = RV Exit Function End If Next i Crawl = Crawl + 1 If Crawl > Reached(0) Then Do Until RetVal(ComponentSearcher) = 0 ComponentSearcher = ComponentSearcher + 1 If ComponentSearcher > UBound(G, 1) Then RetVal(0) = 1 IsBiParite = RetVal Exit Function End If Loop Reached(0) = Reached(0) + 1 If Reached(0) > UBound(Reached) Then RetVal(0) = 1 IsBiParite = RetVal Exit Function End If Reached(Reached(0)) = ComponentSearcher RetVal(ComponentSearcher) = 1
74
End If Loop End Function '-----------------------------------------Mentés------------------------------------Private Sub save(LTree() As MyNode, file As String, Dsw As Boolean) Dim i As Integer Dim Order() As String Open file For Output As #1 Print #1, "DSw " + Str$(Dsw) Order = Split(GetOrder(LTree), " ") For i = LBound(Order) To UBound(Order) If Not (Order(i) = " " Or Order(i) = "") Then Print #1, "Order " + Order(i) Next i For i = 0 Print Print Print Print Print Print Print Print Print Print Print Print Print Print Print Next i Close #1 End Sub
To UBound(LTree) #1, " " #1, "ID " + Str$(i) #1, "Depth " + Str$(LTree(i).Depth) #1, "Direction " + Str$(LTree(i).Direction) #1, "FChild " + Str$(LTree(i).FChild) #1, "IsOnPlace " + Str$(LTree(i).IsOnPlace) #1, "LSibling " + Str$(LTree(i).LSibling) #1, "MidPoint " + Str$(LTree(i).MidPoint(1)) + " " _ + Str$(LTree(i).MidPoint(2)) #1, "NoChild " + Str$(LTree(i).NoChild) #1, "Pair " + Str$(LTree(i).pair) #1, "PairType " + Str$(GetPairType(i, LTree(i).pair, LTree)) #1, "Parent " + Str$(LTree(i).Parent) #1, "Radius " + Str$(LTree(i).Radius) #1, "RSibling " + Str$(LTree(i).RSibling) #1, "Side " + Str$(LTree(i).side)
'---------------------------------------Loading-----------------------------------Private Dim Dim Dim Dim
Sub LoadTree() i As Integer l() As Integer r() As Integer MyAnswer As String
l = ParsePPC(inp) If UBound(l) Mod 2 = 1 Then MsgBox "Error!" Exit Sub End If ReDim Tree(0 To UBound(l)) As MyNode For i = 1 To UBound(l) If l(i) < 0 Or l(i) > UBound(l) Then MsgBox "Error!" Exit Sub End If Tree = AddChildTree(i, l(i), Tree) Tree(i).pair = i + (-1) ^ (i + 1) Next i For i = 1 To UBound(l) r = RootPath(i, Tree) If UBound(r) = 0 Then MsgBox "Error!" Exit Sub Else Tree(i).Depth = UBound(r) End If Next i PutAllCircles Tree BVTouch = TouchRealizable(Tree) If BVTouch Then MyAnswer = "TouchRealizable"
75
mnu_exportTouch.Enabled = True Else MyAnswer = "NonTouchRealizable" mnu_exportTouch.Enabled = False End If DrawTree Tree DrawCircles Tree MyAnswer = MyAnswer + " and " DTree = DoubleSwitch(Tree) DTree = PutAllCircles(DTree) BVTransv = TouchRealizable(DTree) If BVTransv Then MyAnswer = MyAnswer + "Realizable " mnu_exportTransversal.Enabled = True Else MyAnswer = MyAnswer + "NonRealizable " mnu_exportTransversal.Enabled = False End If StatusBar.Panels(1).Text = MyAnswer DrawTree DTree DrawCircles DTree NDTree = DoubleNod(Tree) NDTree = PutAllCircles(NDTree) If TouchRealizable(NDTree) Then mnu_exportDTouch.Enabled = True Else mnu_exportDTouch.Enabled = False End If DrawTree NDTree DrawCircles NDTree Draw End Sub Private Function DoubleNod(LTree() As MyNode) As MyNode() Dim k As Integer, l As Integer, i As Integer, j As Integer, UB As Integer Dim RetVal() As MyNode RetVal = LTree UB = UBound(LTree) ReDim Preserve RetVal(0 To 2 * UBound(LTree)) For i = 1 To UB k = RetVal(i).Parent RetVal = RemoveChildTree(i, RetVal) RetVal = AddChildTree(i, UB + i, RetVal) RetVal = AddChildTree(UB + i, k, RetVal) RetVal(UB + i).Depth = 2 * RetVal(i).Depth - 1 RetVal(i).Depth = 2 * RetVal(i).Depth If LTree(i).PairType = 0 Then RetVal(UB + i).pair = UB + RetVal(i).pair Else RetVal(UB + i).pair = RetVal(i).pair RetVal(i).pair = UB + RetVal(i).pair End If Next i DoubleNod = RetVal End Function Private Dim Dim Dim
Function ParsePPC(Code As String) As Integer() i As Integer, j As Integer, k As Integer RetVal() As Integer Code1 As String, Code2 As String
i = 0 k = 0 Do If InStr(k + 1, Code, ",", vbTextCompare) = 0 Then Exit Do Else
76
k = InStr(k + 1, Code, ",", vbTextCompare) i = i + 1 End If Loop ReDim RetVal(1 To i + 1) k = 0 If Not i = 0 Then For j = 1 To i RetVal(j) = Val(Mid$(Code, k + 1, _ InStr(k + 1, Code, ",", vbTextCompare) - k - 1)) k = InStr(k + 1, Code, ",", vbTextCompare) Next j End If RetVal(i + 1) = Val(Mid$(Code, k + 1)) ParsePPC = RetVal End Function '----------------------------------Processing--------------------------------------------Private Dim Dim Dim Dim
Function PutAllCircles(LTree() As MyNode) As MyNode() G() As Integer Pairing() As Integer i As Integer, j As Integer k As Integer, l As Integer
G = BuildLinkGraph(LTree) Pairing = IsBiParite(G) For i = 1 To UBound(Pairing) k = G(i, -1) l = LTree(k).pair LTree(l).side = Pairing(i) - 1 LTree(k).side = Pairing(i) - 1 j = GetPairType(k, l, LTree) LTree(l).PairType = -j LTree(k).PairType = j LTree(l).IsOnPlace = False LTree(k).IsOnPlace = False Next i LTree(0).PairType = 0 LTree(0).IsOnPlace = 0 LTree = PutCircle(0, 0, 5000, 0, LTree) PutAllCircles = LTree End Function Private Function FindSetChild(Nod As Integer, LTree() As MyNode) As Integer Dim Child As Integer If Not LTree(Nod).FChild = 0 Then Child = LTree(Nod).FChild Do If LTree(Child).IsOnPlace Then FindSetChild = Child Exit Function End If Child = LTree(Child).LSibling Loop Until Child = LTree(Nod).FChild End If FindSetChild = 0 End Function Private Function PutCircle(X As Double, Y As Double, r As Double, _ Nod As Integer, LTree() As MyNode) As MyNode() Dim ujsugar As Double Dim Child As Integer, pair As Integer, pathEdge As Integer Dim k As Integer, i As Integer Dim innerRadius As Double, outerRadius As Double LTree(Nod).MidPoint(1) = X LTree(Nod).MidPoint(2) = Y LTree(Nod).Radius = r LTree(Nod).IsOnPlace = True If LTree(Nod).NoChild = 1 Then
77
Child = LTree(Nod).FChild LTree = PutCircle(X, Y, 9 / 10 * r, Child, LTree) ElseIf LTree(Nod).NoChild > 1 Then If LTree(Nod).PairType = 0 Then ujsugar = Min(r * 1 / 3, (Pi * r * 8 / 10) / LTree(Nod).NoChild) Child = LTree(Nod).FChild k = 1 Do LTree(Child).Direction = 2 * k * Pi / LTree(Nod).NoChild LTree = PutCircle(X + 2 / 3 * r * Cos(LTree(Child).Direction), _ Y + 2 / 3 * r * Sin(LTree(Child).Direction), ujsugar, Child, LTree) Child = LTree(Child).LSibling k = k + 1 Loop Until Child = LTree(Nod).FChild Else pair = LTree(Nod).pair If LTree(Nod).PairType = 1 Then Child = FindSetChild(Nod, LTree) If Child = 0 Then innerRadius = r / 2 Else innerRadius = LTree(Child).Radius End If outerRadius = r * 3 / 4 Else If LTree(pair).IsOnPlace Then innerRadius = LTree(pair).Radius Else LTree = PutCircle(X, Y, r / 2, pair, LTree) LTree(pair).Direction = LTree(Nod).Direction innerRadius = r / 2 End If pathEdge = pair k = 0 Do pathEdge = LTree(pathEdge).Parent If pathEdge = Nod Then Exit Do pathEdge = LTree(pathEdge).pair k = k + 1 Loop pathEdge = pair For i = 1 To k pathEdge = LTree(pathEdge).Parent LTree = PutCircle(X, Y, innerRadius + _ (i - 1 / 2) * (r - innerRadius) / (k + 1), pathEdge, LTree) LTree(pathEdge).Direction = LTree(Nod).Direction pathEdge = LTree(pathEdge).pair LTree = PutCircle(X, Y, innerRadius + _ i * (r - innerRadius) / (k + 1), pathEdge, LTree) LTree(pathEdge).Direction = LTree(Nod).Direction Next i outerRadius = innerRadius + (k + 1 / 2) * (r - innerRadius) / (k + 1) innerRadius = innerRadius + k * (r - innerRadius) / (k + 1) End If ujsugar = Min(5 / 12 * (outerRadius - innerRadius), _ (outerRadius + innerRadius) * Pi / LTree(Nod).NoChild) Child = LTree(Nod).FChild k = 1 Do LTree(Child).Direction = LTree(Nod).Direction + _ 2 * k * Pi / LTree(Nod).NoChild If Not LTree(Child).IsOnPlace Then LTree = PutCircle(X + (outerRadius + innerRadius) / 2 _ * Cos(LTree(Child).Direction), Y + _ (outerRadius + innerRadius) / 2 _ * Sin(LTree(Child).Direction), ujsugar, Child, LTree) k = k + 1 End If Child = LTree(Child).LSibling Loop Until Child = LTree(Nod).FChild End If End If PutCircle = LTree End Function
78
Private Dim Dim Dim Dim Dim
Function GetOrder(LTree() As MyNode) As String RevOrder() As Integer Waiting() As Integer Section() As Integer i As Integer, j As Integer RetVal As String
ReDim RevOrder(0 To UBound(LTree)) For i = 0 To 1 ReDim Waiting(0 To UBound(LTree)) Waiting(0) = 1 Waiting(1) = 0 Do Section = GetSection(Waiting(Waiting(0)), i, LTree) Waiting(0) = Waiting(0) - 1 For j = 1 To Section(0, 0) RevOrder(RevOrder(0) + j) = Section(0, j) Waiting(Waiting(0) + j) = Section(0, j) Next j Waiting(0) = Waiting(0) + Section(0, 0) RevOrder(0) = RevOrder(0) + Section(0, 0) For j = 1 To Section(1, 0) RevOrder(RevOrder(0) + j) = Section(1, j) Waiting(Waiting(0) + j) = Section(1, j) Next j Waiting(0) = Waiting(0) + Section(1, 0) RevOrder(0) = RevOrder(0) + Section(1, 0) Loop Until Waiting(0) = 0 Next i RetVal = "" For j = RevOrder(0) To 1 Step -1 RetVal = RetVal + " " + Str$(RevOrder(j)) Next j GetOrder = RetVal End Function Private Function GetSection(Nod As Integer, side As Integer, LTree() As MyNode) _ As Integer() Dim Section() As Integer Dim Waiting() As Integer Dim Searcher As Integer, Child As Integer Static Check() As Integer Dim i As Integer ReDim Section(0 To 1, 0 To UBound(LTree)) 'Horiz, Vert ReDim Waiting(0 To UBound(LTree)) ReDim Check(1 To UBound(LTree)) Waiting(0) = 1 Waiting(1) = Nod If LTree(Nod).PairType = 0 And Not Nod = 0 Then Waiting(0) = 2 Waiting(2) = LTree(Nod).pair End If Do Searcher = Waiting(Waiting(0)) Waiting(0) = Waiting(0) - 1 Child = LTree(Searcher).FChild If Not Child = 0 Then Do If side = Abs(LTree(Child).side) Then If LTree(Child).PairType = 0 And Check(Child) = 0 Then Section(0, 0) = Section(0, 0) + 1 Section(0, Section(0, 0)) = Child Check(Child) = 1 Check(LTree(Child).pair) = 1 Else If Not Child = LTree(Nod).pair And Check(Child) = 0 Then Section(1, 0) = Section(1, 0) + 1 Section(1, Section(1, 0)) = Child
79
Waiting(0) = Waiting(0) + 1 Waiting(Waiting(0)) = LTree(Child).pair Check(Child) = 1 Check(LTree(Child).pair) = 1 End If End If Else Waiting(0) = Waiting(0) + 1 Waiting(Waiting(0)) = Child End If Child = LTree(Child).LSibling Loop Until Child = LTree(Searcher).FChild End If Loop Until Waiting(0) = 0 GetSection = Section End Function
Form2.frm VERSION 5.00 Begin VB.Form Form2 BackColor = &H80000004& ClientHeight = 4680 ClientLeft = 60 ClientTop = 450 ClientWidth = 7890 LinkTopic = "Form2" ScaleHeight = 4680 ScaleWidth = 7890 StartUpPosition = 3 'Windows Default Begin VB.CommandButton btnOk Caption = "Ok" Height = 375 Left = 1680 TabIndex = 1 Top = 0 Width = 3135 End Begin VB.CommandButton btnClear Caption = "Clear" Height = 375 Left = 0 TabIndex = 0 Top = 0 Width = 1695 End End Attribute VB_Name = "Form2" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Type CircleDat mX As Single mY As Single rX As Single rY As Single End Type Dim Present As Integer Dim MoR As Integer Dim MyCircles() As CircleDat Private Sub btnClear_Click() ReDim MyCircles(0 To 0) End Sub Private Sub btnOk_Click() Form1.inp = Create Unload Me End Sub Private Sub Form_Load()
80
ReDim MyCircles(0 To 0) End Sub Private Function IsSub(i, j) As Boolean Dim D As Single D = Dist(MyCircles(i).mX, MyCircles(i).mY, MyCircles(j).mX, MyCircles(j).mY) IsSub = (D + Rad(i) < Rad(j)) End Function Private Function Rad(i) As Single Rad = Sqr((MyCircles(i).mX - MyCircles(i).rX) ^ 2 + _ (MyCircles(i).mY - MyCircles(i).rY) ^ 2) End Function Private Function Dist(X1 As Single, Y1 As Single, X2 As Single, Y2 As Single) As Single Dist = ((X1 - X2) ^ 2 + (Y1 - Y2) ^ 2) ^ (1 / 2) End Function
Private Sub Fresh() Dim i As Integer If UBound(MyCircles) > 0 Then Cls For i = 1 To UBound(MyCircles) Circle (MyCircles(i).mX, MyCircles(i).mY), 40, QBColor(0) Circle (MyCircles(i).rX, MyCircles(i).rY), 40, QBColor(0) Circle (MyCircles(i).mX, MyCircles(i).mY), Rad(i), _ QBColor(Int(i + i Mod 2 - 1) Mod 15) Next i End If End Sub Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _ X As Single, Y As Single) Dim i As Integer If UBound(MyCircles) > 0 Then For i = 1 To UBound(MyCircles) If Dist(X, Y, MyCircles(i).mX, MyCircles(i).mY) < 40 Then Present = i MoR = 1 Exit Sub ElseIf Dist(X, Y, MyCircles(i).rX, MyCircles(i).rY) < 40 Then Present = i MoR = 2 Exit Sub End If Next i End If Present = UBound(MyCircles) + 1 MoR = 2 ReDim Preserve MyCircles(0 To Present) MyCircles(Present).mX = X MyCircles(Present).mY = Y MyCircles(Present).rX = X MyCircles(Present).rY = Y Fresh End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) If Not Present = 0 Then If MoR = 1 Then MyCircles(Present).mX = X MyCircles(Present).mY = Y Else MyCircles(Present).rX = X MyCircles(Present).rY = Y End If Fresh End If End Sub Private Sub Form_MouseUp(Button As Integer, Shift As Integer, _ X As Single, Y As Single)
81
Present = 0 btnOk.Enabled = Check End Sub Private Function Check() As Boolean Dim i As Integer Dim j As Integer If UBound(MyCircles) Mod 2 = 1 Then Check = False Exit Function End If For i = 1 To UBound(MyCircles) For j = 1 To UBound(MyCircles) If Not i = j And Not IsSub(i, j) And Not IsSub(j, i) Then If Rad(i) + Rad(j) >= Dist(MyCircles(i).mX, MyCircles(i).mY, _ MyCircles(j).mX, MyCircles(j).mY) Then Check = False Exit Function End If End If Next j Next i Check = True End Function Private Function Create() As String Dim i As Integer, j As Integer Dim RetVal As String Dim ParentID() As Integer ReDim ParentID(1 To UBound(MyCircles)) For i = 1 To UBound(MyCircles) For j = 1 To UBound(MyCircles) If Not i = j And IsSub(i, j) Then If ParentID(i) = 0 Then ParentID(i) = j ElseIf IsSub(j, ParentID(i)) Then ParentID(i) = j End If End If Next j Next i RetVal = Str$(ParentID(1)) For i = 2 To UBound(MyCircles) RetVal = RetVal + "," + Str$(ParentID(i)) Next i Create = RetVal End Function Private Sub Form_Paint() Fresh End Sub Private Sub Form_Resize() btnClear.Width = Me.ScaleWidth / 2 btnOk.Width = Me.ScaleWidth / 2 btnOk.Left = Me.ScaleWidth / 2 End Sub
82
