| 1 | REBOL [
|
|---|
| 2 | TITLE: "Enhanced area"
|
|---|
| 3 | auteurs: "Shadwolf, Steeve"
|
|---|
| 4 | start-date: 07/04/2009
|
|---|
| 5 | release-date: 22/04/2009
|
|---|
| 6 | credits: { Carl sassenrath, Steeve, Maxim, Coccinelle, Cyphre (AGG guru ^^)}
|
|---|
| 7 | purpose: { construct a new style "area-tc",
|
|---|
| 8 | with rendering dynamic colorized text using draw/agg}
|
|---|
| 9 | Download: http://my-svn.assembla.com/svn/shadwolforge/
|
|---|
| 10 | Docstrack: { docs, source diff and time tracs available on
|
|---|
| 11 | http://my-trac.assembla.com/shadwolforge/
|
|---|
| 12 | }
|
|---|
| 13 | ]
|
|---|
| 14 | ;print ""
|
|---|
| 15 |
|
|---|
| 16 | ; utility functions
|
|---|
| 17 |
|
|---|
| 18 | sav-pref: func [][
|
|---|
| 19 | ;consol_path: fi/text
|
|---|
| 20 | pref/bg_color: b1/color
|
|---|
| 21 | pref/txt_color: b2/color
|
|---|
| 22 | save %pref.dat pref
|
|---|
| 23 | ]
|
|---|
| 24 |
|
|---|
| 25 | load-pref: func [][
|
|---|
| 26 | if exists? %pref.dat [pref: do load %pref.dat]
|
|---|
| 27 | ]
|
|---|
| 28 |
|
|---|
| 29 | either exists? %pref.dat [
|
|---|
| 30 | load-pref
|
|---|
| 31 | ][
|
|---|
| 32 | pref: make object! [
|
|---|
| 33 | ;consol_path: copy system/options/boot
|
|---|
| 34 | bg_color: 255.255.255
|
|---|
| 35 | txt_color: 0.0.0
|
|---|
| 36 | ]
|
|---|
| 37 | ]
|
|---|
| 38 | ; LOAD MENU WIDGET Cyphre(TM)
|
|---|
| 39 | do load decompress #{
|
|---|
| 40 | 789CB51B6B73DAB8F67B7E85BA3B770237430CE4D12EDD6EC6109A92266D499A
|
|---|
| 41 | B629E3CE1810C6606C6A9BE074BBFFFD9E23C9B66CCB84A477C384C8B2747474
|
|---|
| 42 | 5E3A0FE5EF5118D516D45DB5C8C29C53E20D6774143E23839D6F357B615A3468
|
|---|
| 43 | 119F8E5723CABABED55EE260329C5B646D875342C71665FD8E678EC9F1E1EF7F
|
|---|
| 44 | DB9FDAEFAFD6F5B76796A7C3CFBBEB9B69F7C68256BB87CFD71DFD161F3EFFF0
|
|---|
| 45 | 8EBE6047FB6CDCFE78D3D5F58BB3F7930FE1D5CE7C0DBD9DF6ECFAF5F93B787D
|
|---|
| 46 | 7CDED775AB77A9EB1F5C0D5EE8C7F07AFC11BEDE2F11ECB103E35F37F7BE7CFF
|
|---|
| 47 | EADE20C09DE6DCE9F63F5D1DBA67172F34ED85A6FFB8D1FB7A27B27A33FFD38B
|
|---|
| 48 | BDABAFE7DF17E1B43B5B4DA7B06AD7BABE3A773AEFDAD7FE7BC07074D5DDB1E7
|
|---|
| 49 | 776BC4D25B2EDB00BBFBEE1656F7ACC08AACAF67572BBDD9A6BDC6E7B6ADEB6F
|
|---|
| 50 | BAD6FCC5E91B5B3F8F2EBFF6FBD142BFA6D6E71D58EDEAF8C7CDF2EB25ECA0D3
|
|---|
| 51 | D1DFBEE95E754EEFDF74FA7AB7FBEEA67376DFD1BF9FDDF6FBFA69FBEEF6D68F
|
|---|
| 52 | AE7A17BADEEB0DDB9DE69DFEFEEDCE17EB6BEFB6F7767D7EEE0125EF69AF1FE8
|
|---|
| 53 | EDB61E5993FAE5349AF5828B4B86E17A31E97FBC9E863F7AFACDFBFACCBA38EF
|
|---|
| 54 | 996DA0FBCE6D70F5E58D7DE67EE94CFBFDD7A3D3C6C58B8B2BFDB2DB7D7D7C7A
|
|---|
| 55 | AD03B5FBB7FAC5DC72BF1EDE6B07EDBECE5873F3E9FDD5DBA3CE6DAFF7EA1F89
|
|---|
| 56 | D9A3291DCD413CFCF9969CD6D9578F73FAB47BFAFCF8E2DFE1F44D3DE6F4F97C
|
|---|
| 57 | 4FDFEBAE7AB0F41A609DBE99CED7FDB6A5B7EDFECAB4AE0F7B20017A74DBB7EC
|
|---|
| 58 | B707CF3F009C7EFFEDF4F38ED75D74901A97D7AF7FD43B9FDAC8ACB3CBCE9ED5
|
|---|
| 59 | EDB65FB70F6F75ABDFEF358EEE74EB3540EEEA7BF3E0CB878F079ED6EE3292ED
|
|---|
| 60 | E46966C06F10DE3BF60FAA2DCC20A4BED01BAE6313131489290EEFFD561B798E
|
|---|
| 61 | E7B788EBB954F44C3C3714DA88CD64643276E898A379D2E94D26018509F5A89E
|
|---|
| 62 | F4055373ECAD33500DF117155640C7A6043D009C5BA41135F2EB359E37F71BC7
|
|---|
| 63 | 2FF61B4707DF6A39706BCF1F838948A18CCDD0240397AE356CC18E6D3F08894B
|
|---|
| 64 | A39098BE15A42D2399623ACBA92981F856C3E9ACB7305F1A04066A42827BA0F1
|
|---|
| 65 | 421BAE6C678C2B52F22769366AE7A65B6BD6EB8719A839C8CDA323522324E9C9
|
|---|
| 66 | 8C34A4A70C62793C8C1C41BC498617410838B5083029E5376C8A711824A236C9
|
|---|
| 67 | 304960164F9E50EAC492004D69333EE5DC9AACDC11190019E069CF90374B41C8
|
|---|
| 68 | 40F896A6ED9F90898603C84034B4A895B4C81E9F0C2D79CFF1D078603C4C1E13
|
|---|
| 69 | 4CBD35991428912388EDDA612B2BC42D62BAF764C0C48B6D3F850A2C75BD90F0
|
|---|
| 70 | 57032180CD83E3FDE6C1C17EB3719C8E5C9A2E6037F2960029ED659445B5497B
|
|---|
| 71 | 3C9F9A2350389B0C0DC2C553DA84ED06D40F4968DA0E419082DCE688E6642704
|
|---|
| 72 | D6B7889DE9E3CA243130A337857E3835F93BE9503DFC63BF513FDE6FFCF13C47
|
|---|
| 73 | 098EBB1B1666ACA73688393302C5D1B1B8A0DD301DDB725B64D7A193303B7269
|
|---|
| 74 | FAA618894D80E99BCB13344F4E003E806F5B364C6C46F5EC342E1087D1214883
|
|---|
| 75 | 45C35AC84408D7B271C5CCD8D82C813E64FAB9551812FCC9625F2AEC02E01DF5
|
|---|
| 76 | 5381378967E44730E9311D986A82D4C2C628500F39A9312DCCF571F55300E1B6
|
|---|
| 77 | 5A0315A321CC4184156354C0346F19DA9E1B2858BF6152B85872ABA10629E858
|
|---|
| 78 | 59DBAE202AE873153850A9470DF25FA19F553065F5E870DB353927033AF2DC31
|
|---|
| 79 | 0940EE4FD4AB732563D695D9AB7887822E894CEE7285CDC2803EB28BD231D1D8
|
|---|
| 80 | 41B6CB0D7D7610EB33B6C55B9C29654CE1164931B130B6B8E244136ABBB4C1DB
|
|---|
| 81 | 9968A9B292E2527C47B91992B62AA6E4ACA51A0DEA5AA6456531A70A090DC083
|
|---|
| 82 | 008B661674842998B776952FF2241547139A5BC50B0500159756CB92B5401555
|
|---|
| 83 | 3AA81E0C16C99BE715945963DB1DD3088413FEAA5E8324536722AC066F0F5468
|
|---|
| 84 | E2671BAD8E1905F82C574B0D740EC8A9996BF35E2956ADD2D342FE240AFECBBA
|
|---|
| 85 | 2C84447DEAC89FB2132823289B7549880C3B53F2C63D4356738426A1852702B0
|
|---|
| 86 | 2B4B27D079F6B67476A981798C7979BC71119C2E5A41C4A7743CC8346C50B89C
|
|---|
| 87 | 77365D935D90135CA9A63CB232847CE078933F78368E1C2FA0357A077B41FF9A
|
|---|
| 88 | 3D96EF84CF015FC61ED393C47C2003180483B75FF1270D1F1E82B5F4BD110D82
|
|---|
| 89 | 9AB70A1128C74405F90138F8B3721D00C59578B080839C84F68212148D3B5471
|
|---|
| 90 | D198D37BC2AC5730F23DC7A93936F84302E5F07E097230454C986A3E843EFEB0
|
|---|
| 91 | 990F8C7B900CDEB236A6211D852DE0E153362F1C71C11B92CE7E5004721018F9
|
|---|
| 92 | 64B128210DF723C980A3B8C51AC6D698288542DAD2368BFD0243CADF95BD3118
|
|---|
| 93 | D56ADC8E174EDFF8B336EDB0FCDC509E9ACC53564E508129F6E57BB2CFF293DC
|
|---|
| 94 | 16A74888274623AAC3895129F1C6C12456AB85D0EC5BEDE543364F0C38AED7A3
|
|---|
| 95 | 669A504093A5F1A093B0539687E5B17DE6FD6C621232C47F172B27B485E5636D
|
|---|
| 96 | 49DA26B643333665E8CC334A0516973957D04F1A393165ECE087184B49719460
|
|---|
| 97 | A4927859B40C96AA81AF8470311AEC7510FAECAF961E7C136F38C3497C804FC3
|
|---|
| 98 | 95EFB22DB3C050E107A003844A9E49E70C672067312A22E152879F887D8B7E1E
|
|---|
| 99 | 69C638705459582D7248299ECC0B49CEEFF8EC640F041E44EF24CE56404BF42D
|
|---|
| 100 | CD702A3A97A2C55D23DE74BC91E9B0E65D92E0F55760C4590BED329F0381E842
|
|---|
| 101 | 38D7E355DC0A5643DE630727AC319ACE79C35E58ECEFD0F44547B8607FC1F2B3
|
|---|
| 102 | BF3402591CF377AE07E6920F172C8D43C9241309188340C95CC1E76C5200D8C0
|
|---|
| 103 | 3616B305741942DC847004B605C76BE0C1793440C0102F7B2EA960536BE0C304
|
|---|
| 104 | 1CB49F04BD4614C2219066FE8C543818EC010055783FB79706093D42DD315F98
|
|---|
| 105 | E076EC30E16192DB40DA275282BB0CB2181B29E15BE4203A48C99BA65114C1F0
|
|---|
| 106 | D843E72476C2B82E9818976C769D779937B28B001F31CBC41457925254052DBF
|
|---|
| 107 | 860E07F92884A84C3D2E982AF7BCE03C6F4CC0629E2A3172D4013700F52A753B
|
|---|
| 108 | 8DE4D478446E67DBAC4E2E7768A4CA9718F0ACDDFFEDF237C277AE2529B08CD0
|
|---|
| 109 | 81AEC7B2561766881D29A9962BD4834AF95DAE278951455A0C7641D1CDA14349
|
|---|
| 110 | 0535BE45427F45AB06A3D380E5F976E1B4421B205E8136EDD6E21E768E560D31
|
|---|
| 111 | 1CB50C8C0419B0D2D33318892704FE45FC9FC5C376C180900A5A91643536335C
|
|---|
| 112 | A0D5B45DEB191FF73BEB46B75274C7F3C144910A33300900AEFB0916C21211BE
|
|---|
| 113 | 6134093F992D90314DED81412AD2A1C3625926B43CAB08946F908A8864719DAA
|
|---|
| 114 | 34384E59A1809C24CBB22E84CF90348C814853E26C8E471604235AE674147C67
|
|---|
| 115 | 843C89896A89A3125A598783BD0A3D5EF293B5466887E553EA92547738DC1683
|
|---|
| 116 | 4B2713748F4129C08B4A8A08E09B3051355E368E23396F9BF568004D9040ED1E
|
|---|
| 117 | 629383FC0EA4CC2CB7EC04F896D169F2127A588D0A9F732E15FAC580557C1CC9
|
|---|
| 118 | 9B15B86379536BBC64E2CEAB214390217349FE634D2216E2EF2F5D2B373BDEEE
|
|---|
| 119 | C85B2CC117073F3B0AC1E813166B8283432A65468347A8CDA323A3CA13DCE835
|
|---|
| 120 | 958E96B2E3D5BCB7581EDE97E606D4E97289090119A439DB20DCCE218599A886
|
|---|
| 121 | 1B3807E4D7F27975C2EB8A63EAD80BB057BE9A710058BD6DA91EB5EDEE13574B
|
|---|
| 122 | AA6E091396E6A9C18F06A7B774DF19F73B9F9FE1C6281F156448554A146EB213
|
|---|
| 123 | B2E06306B6A047B19F5724C2450E4975E2DDF73CF42A73DA90398B44A089669C
|
|---|
| 124 | 0C061299659283319226955720BC7C098208F649B3B5E653EA12982B83238599
|
|---|
| 125 | 1730331008E51444442251B31819C11191A90E31A9111A1D47EA92C92C0820D3
|
|---|
| 126 | 796D4CE9920CC6BEB9164715BA4360E2175695D4F741C3F7EB464E81F2A0C462
|
|---|
| 127 | 780A2AC2EF0C6C0CF184B16A9680572C80BE65410FCAB51A04741C0903B14C82
|
|---|
| 128 | 03C1D6C79666088F20C88C848B25FE7AF815E0976D902C150B68C3A0B2F89A1F
|
|---|
| 129 | 6A35FA7D653A2719416AC822AACC673C2ABFFFA40C7F31CA57E6FCE532154FBE
|
|---|
| 130 | A36A663CDB3809FA0A5E025BD4099AF2792D3EAD300742928A0A12F4CFD2AA73
|
|---|
| 131 | EE4D5C3F75B96CB08045890FC12F803303ADCB5BD9FCCE2B0E78F8E1F484235A
|
|---|
| 132 | 257FBE2249975B65647193DD6FCCAC7307AE74048421C9415D0107074C638DF9
|
|---|
| 133 | C2E2C89D79109E0C7621F0406292DD4CEE1A3D6003F1C97B5CD98F4F594ED30C
|
|---|
| 134 | 057166A52319756AA5D4512D414A324A55456745D127EC4CD6A1243CBC050AB3
|
|---|
| 135 | 9D95E4FF4AD3829BC98E32A3F1B43F999448221B97C4C9998D0D54BD6011D5DD
|
|---|
| 136 | 6A188AF594F42A2D5DA1D92AABA115B44E594C2D8CDA504A2D8C55153F846F28
|
|---|
| 137 | 46F3334B7889E8472A0AADEA19B19F5A26CF42602A251B65374614EF44910B5E
|
|---|
| 138 | 436CC7E3F624F89732B0E08F6385AB4AFE22F50D69676081642294B44410F994
|
|---|
| 139 | 60414C3DB55993463063A95C406B8AE23BDBF231D90CC756C249A8B261726C60
|
|---|
| 140 | 6D7ECBA9049B8D3B4DB8868800B2B68CB91DF3ED2FF2105F1E5824DE285BA526
|
|---|
| 141 | AF524B567900403AA7C5FD8274261279E3EC8DE51625F03DEE76D41E02BCF12D
|
|---|
| 142 | 1792ADF6C7252E4563C3E027D432CAB7AF7205124A3C412CCB5040B5E47BE492
|
|---|
| 143 | C4BF379A3C38DB376A7A2AFD4F117C99E319A1378781E7AC42CAE4E0D1A4FE05
|
|---|
| 144 | 8A72992B5FF297CE8F47B24B5C87C983528EDED2C9D85CB7FA3F5E6099C49536
|
|---|
| 145 | F022CA2E9EB03B26E25E49DEE530480A41EDBCB15B1D83CDA3B62FD32519371E
|
|---|
| 146 | 3DE7E6C57724A452D79DE9AC681C28452C32F5E154264A874DE5A2257EADCAB3
|
|---|
| 147 | D9E0EA32D7B6D4DB85D80FFDDDE28D8D2D02CE38B0F35CE75E89166C92DF81D6
|
|---|
| 148 | 3077A118C0D3CF6C448953C4CA354A09CEE5A6B39F48DC39DDDD63E96783D1BB
|
|---|
| 149 | 126189870B2344A31313738CD047067B301206D57082610CA04FE970E3E72789
|
|---|
| 150 | 5AB9B21082C0B250E90CAC16A9B550949054CAA85415520119C92F14D7DAD574
|
|---|
| 151 | 5CC48A9248E12F887D2E1988B9F6C7E602C14AF9E1681516135F49EA2BAE0FA6
|
|---|
| 152 | 9FF20CE813EFB666925752112549812B2EDC6E4838F2DC5C116F6EEB9B8AD414
|
|---|
| 153 | 922E5FBC493FE2F0B96FF174791EF55C82262DC6AA39086B15B0CE7172B3FD79
|
|---|
| 154 | 98ABA6EFC3E153CE52F67E6BA696D239CEDD0DF87AF5FDE7F00B1FE27BEC5CF8
|
|---|
| 155 | A3C0E64285E25FA474194DE3320FC6DFAEA1222DB7A18CBE3CA9A04CCCB14A13
|
|---|
| 156 | D697E25889D79AF68863825F961FAD28A8F0407412B00B0149448A28629A9B9D
|
|---|
| 157 | 1808B25E128C4A858A5D9E5E4DF5261B84A605906DEEB6F0DB9095B20CAEB44C
|
|---|
| 158 | 55B67D80774148784D32D7C9CA5DB93E5E8FCC750A4615FA45ED30D39B629231
|
|---|
| 159 | F0F11E25C3CEBBC41D92F412C30EBBE4C13204995B1EE9058FF45E867C3323BD
|
|---|
| 160 | 1921DFCDE0D1C84E725067FE312577BBE0A1A23262A03552BB943AED99FFA7B0
|
|---|
| 161 | 852B5B6902F7D81278B735E3D8DAB21F2B7BEF7238920BA3EEF3C3EFE597B082
|
|---|
| 162 | ACA8316A33B194FC0F4EDCEB9C891B73123B8BC7D62C1358A4898F38807E8040
|
|---|
| 163 | 79F1CE5F8A5253AAD26477BA18373653EE49BB44B5891369E93EE37F084A7659
|
|---|
| 164 | 93B0D222BC8C7CA8DC1378B5CCE66E41B81A99A54D01B8042696F69F80E28B52
|
|---|
| 165 | 24C4202067732BD6487628BE646727D7B20587528E714B85025B2DAAB6505CE9
|
|---|
| 166 | F69674D5077ACCF13873A72BBDFD1697FB714A72A52D003F4943CBA2C141A2A1
|
|---|
| 167 | B30D5E5D6C99F9D04301C9244363202209FC77431B040804940CD96F930C307B
|
|---|
| 168 | 8BB782C12732E21B663C8F5D82914872B36B38325AB011E325D6BFBD0989FF97
|
|---|
| 169 | 78E79FFF0120649CE6573C0000
|
|---|
| 170 | }
|
|---|
| 171 | ; END of ctx-menu
|
|---|
| 172 | area-tc: context [ ;** global context
|
|---|
| 173 |
|
|---|
| 174 | colors: [
|
|---|
| 175 | char! 0.180.40
|
|---|
| 176 | date! 0.120.150
|
|---|
| 177 | decimal! 0.120.150
|
|---|
| 178 | email! 0.180.40
|
|---|
| 179 | file! 0.180.40
|
|---|
| 180 | integer! 0.120.150
|
|---|
| 181 | issue! 0.180.40
|
|---|
| 182 | money! 0.120.150
|
|---|
| 183 | pair! 0.120.150
|
|---|
| 184 | string! 0.180.40
|
|---|
| 185 | tag! 0.180.40
|
|---|
| 186 | time! 0.120.150
|
|---|
| 187 | tuple! 0.120.150
|
|---|
| 188 | url! 250.120.40
|
|---|
| 189 | refinement! 160.120.40
|
|---|
| 190 | comment! 255.88.9
|
|---|
| 191 | datatype! 120.60.100
|
|---|
| 192 | function! 255.0.0
|
|---|
| 193 | native! 255.0.0
|
|---|
| 194 | action! 255.0.0
|
|---|
| 195 | error! 255.0.0
|
|---|
| 196 | multi! 0.180.40
|
|---|
| 197 | free-text! 0.0.200
|
|---|
| 198 | ]
|
|---|
| 199 | insert tail colors compose [ block! (pref/txt_color) default! (pref/txt_color) ]
|
|---|
| 200 | ;func-list: make string! 5000
|
|---|
| 201 | ;foreach fun bind first system/words system/words [
|
|---|
| 202 | ; if all [value? :fun any-function? get :fun][
|
|---|
| 203 | ; insert insert tail func-list #" " form fun
|
|---|
| 204 | ; ]
|
|---|
| 205 | ;]
|
|---|
| 206 | ;**print length? func-list
|
|---|
| 207 | multi-chars: complement charset "^^}^/^-" ;** to detect end of rebol strings
|
|---|
| 208 | save-color: color: start: end: out-style: x:
|
|---|
| 209 | str: type: f: value: multi: grow?: none
|
|---|
| 210 |
|
|---|
| 211 | ;** markers used in replacement of the draw comman PUSH. Much easy to track them.
|
|---|
| 212 | expand: ;** marker for info messages (like errors)
|
|---|
| 213 | hilight: 'push ;** marker for hilight background
|
|---|
| 214 | no-edit: edit: 'aliased
|
|---|
| 215 |
|
|---|
| 216 | edit-mode: none
|
|---|
| 217 |
|
|---|
| 218 | abs-x: 0
|
|---|
| 219 | ;** rule to output draw dialect
|
|---|
| 220 | gen-draw: [end: (
|
|---|
| 221 | str: copy/part start end
|
|---|
| 222 | unless tail? str [
|
|---|
| 223 | color: any [select colors type color select colors 'default! 0.0.0]
|
|---|
| 224 | abs-x: x * f/x + f/origine-x
|
|---|
| 225 | either save-color <> color [
|
|---|
| 226 | if block? color [
|
|---|
| 227 | out-style: insert insert insert insert insert insert insert insert out-style
|
|---|
| 228 | 'pen color/2 'fill-pen color/2 'box
|
|---|
| 229 | as-pair abs-x 7 as-pair (f/x * length? str) + abs-x 7 + f/y 3
|
|---|
| 230 | type: none
|
|---|
| 231 | color: color/1
|
|---|
| 232 | ]
|
|---|
| 233 | out-style: insert insert insert insert insert out-style
|
|---|
| 234 | 'pen color [text edit] as-pair abs-x + f/xy/x 5 str
|
|---|
| 235 |
|
|---|
| 236 | ][
|
|---|
| 237 | insert tail pick out-style -1 str
|
|---|
| 238 | ]
|
|---|
| 239 | if type = 'error! [
|
|---|
| 240 | out-style: insert/only insert out-style 'expand
|
|---|
| 241 | reduce ['pen red 'text 'vectorial as-pair abs-x 5 + f/y reform [value/id value/arg1]]
|
|---|
| 242 | ]
|
|---|
| 243 | x: x + length? str
|
|---|
| 244 | save-color: color
|
|---|
| 245 | if type = 'error! [grow?: true]
|
|---|
| 246 | ]
|
|---|
| 247 | )]
|
|---|
| 248 | tab1: next tab2: next tab3: next tab4: " "
|
|---|
| 249 | what: none
|
|---|
| 250 | gen-tab: [(
|
|---|
| 251 | what: pick [tab4 tab3 tab2 tab1] x // 4 + 1 ;** align tabs
|
|---|
| 252 | out-style: insert insert insert out-style
|
|---|
| 253 | [text edit] as-pair x * f/x + f/xy/x + f/origine-x 5 what
|
|---|
| 254 | x: x + length? get what
|
|---|
| 255 | save-color: none
|
|---|
| 256 | )]
|
|---|
| 257 |
|
|---|
| 258 | spaces: exclude charset [#"^(1)" - #" "] charset "^/^-" ;** treat like space
|
|---|
| 259 |
|
|---|
| 260 | ;** rule to detect rebol values (uses load/next)
|
|---|
| 261 | ;** (heavy, because we handle errors too)
|
|---|
| 262 | rebol-value: [skip (
|
|---|
| 263 | error? set/any [value end] try [load/next start]
|
|---|
| 264 | either error? :value [
|
|---|
| 265 | value: disarm :value
|
|---|
| 266 | either value/arg2/1 = #"{" [
|
|---|
| 267 | end: any [find start newline tail start]
|
|---|
| 268 | type: 'multi!
|
|---|
| 269 | multi: case [
|
|---|
| 270 | multi < 2 [3]
|
|---|
| 271 | multi = 2 [4]
|
|---|
| 272 | 'else [multi]
|
|---|
| 273 | ]
|
|---|
| 274 | ][
|
|---|
| 275 | end: skip start length? value/arg2
|
|---|
| 276 | type: 'error!
|
|---|
| 277 | ]
|
|---|
| 278 | ][
|
|---|
| 279 | case/all [
|
|---|
| 280 | path? :value [value: first :value]
|
|---|
| 281 | all [word? :value value? :value][value: get value]
|
|---|
| 282 | any-string? :value [
|
|---|
| 283 | if find/part start newline end [
|
|---|
| 284 | end: find/part start newline end
|
|---|
| 285 | multi: case [
|
|---|
| 286 | multi < 2 [3]
|
|---|
| 287 | multi = 2 [4]
|
|---|
| 288 | 'else [multi]
|
|---|
| 289 | ]
|
|---|
| 290 | type: 'multi!
|
|---|
| 291 | ]
|
|---|
| 292 | ]
|
|---|
| 293 | ]
|
|---|
| 294 | type: type?/word :value
|
|---|
| 295 | color: none
|
|---|
| 296 | ]
|
|---|
| 297 | ) :end
|
|---|
| 298 | ]
|
|---|
| 299 |
|
|---|
| 300 | no-tabs: complement charset "^/^-"
|
|---|
| 301 | gen-to-end: [any [some no-tabs | end: tab :end gen-draw some [tab gen-tab] start:] gen-draw]
|
|---|
| 302 | any-char: complement charset " ^-"
|
|---|
| 303 |
|
|---|
| 304 | ;** construct a draw block for one line
|
|---|
| 305 | set 'colorize func [
|
|---|
| 306 | face line out
|
|---|
| 307 | /local check-multi check-free-text orig lvl-start lvl val cont pline pos
|
|---|
| 308 | ][
|
|---|
| 309 | color: save-color: grow?: none
|
|---|
| 310 | f: face
|
|---|
| 311 | x: 0
|
|---|
| 312 | orig: out-style: out
|
|---|
| 313 |
|
|---|
| 314 | ;** multi = -1, free text before REBOL header
|
|---|
| 315 | ;** multi = 0, code not parsed
|
|---|
| 316 | ;** multi = 1, normal code
|
|---|
| 317 | ;** multi = 2, end of multi-line string
|
|---|
| 318 | ;** multi = 3, begin of multi-line string
|
|---|
| 319 | ;** multi = 4, full multi-line string
|
|---|
| 320 |
|
|---|
| 321 | lvl: lvl-start
|
|---|
| 322 | multi: case [
|
|---|
| 323 | head? line [-1]
|
|---|
| 324 | 2 < val: first pline: pick line -1 [4]
|
|---|
| 325 | val = -1 [-1]
|
|---|
| 326 | 'else [1]
|
|---|
| 327 | ]
|
|---|
| 328 | lvl: lvl-start: either pline [pline/3/2][1]
|
|---|
| 329 | line: line/1
|
|---|
| 330 |
|
|---|
| 331 | check-multi: if multi <> 4 [[end skip]]
|
|---|
| 332 | check-free-text: [(cont: if multi <> -1 [[end skip]]) cont]
|
|---|
| 333 |
|
|---|
| 334 | ;**all [char? line/2 print line]
|
|---|
| 335 | parse/all line/2 [
|
|---|
| 336 | start:
|
|---|
| 337 | check-free-text "rebol" any #" " #"[" (multi: 1) end skip
|
|---|
| 338 | | check-free-text (type: 'free-text!) gen-to-end
|
|---|
| 339 | | opt [
|
|---|
| 340 | check-multi start: some [
|
|---|
| 341 | some multi-chars
|
|---|
| 342 | | #"^^" [skip | end]
|
|---|
| 343 | | end: tab :end (type: 'multi!) gen-draw some [tab gen-tab] start:
|
|---|
| 344 | | #"}" (multi: 2) break ;** end of multi-line
|
|---|
| 345 | | break ;** newline
|
|---|
| 346 | ]
|
|---|
| 347 | (type: 'multi!) gen-draw
|
|---|
| 348 | ]
|
|---|
| 349 | any [
|
|---|
| 350 | start: [newline | end] break
|
|---|
| 351 | | some spaces (type: 'blank!) gen-draw
|
|---|
| 352 | | tab gen-tab
|
|---|
| 353 | | [#"[" | #"("] (type: 'block! lvl: lvl + 1) gen-draw
|
|---|
| 354 | | [#"]" | #")"] (type: 'block! lvl: lvl - 1) gen-draw
|
|---|
| 355 | | #";"(type: 'comment!) gen-to-end
|
|---|
| 356 | | rebol-value gen-draw
|
|---|
| 357 | ]
|
|---|
| 358 | ]
|
|---|
| 359 |
|
|---|
| 360 | line/1: multi
|
|---|
| 361 | line/3: as-pair lvl-start lvl
|
|---|
| 362 |
|
|---|
| 363 |
|
|---|
| 364 | f/h-scroller/max-x: max f/h-scroller/max-x x * f/x + f/origine-x + (f/x * 10)
|
|---|
| 365 | ;**f/cursor/len: x
|
|---|
| 366 |
|
|---|
| 367 | case [
|
|---|
| 368 | empty? orig [ ;** if the text contains no chars, add a dummy line
|
|---|
| 369 | append orig compose [text edit (as-pair f/origine-x + f/xy/x 5) (copy "")]
|
|---|
| 370 | ]
|
|---|
| 371 | not same? back start find/reverse start any-char [
|
|---|
| 372 | insert insert insert tail orig
|
|---|
| 373 | [pen blue text no-edit]
|
|---|
| 374 | as-pair x * f/x + f/origine-x + f/xy/x 5
|
|---|
| 375 | "�"
|
|---|
| 376 | ]
|
|---|
| 377 | ]
|
|---|
| 378 | grow? ;** notices if it's a simple line or a double-size line
|
|---|
| 379 | ]
|
|---|
| 380 |
|
|---|
| 381 | ;** cut text into lines
|
|---|
| 382 | set 'build-data func [
|
|---|
| 383 | text f /local out
|
|---|
| 384 | ][
|
|---|
| 385 | out: f/data
|
|---|
| 386 | clear out
|
|---|
| 387 | parse/all text [any [pos: (out: insert/only out reduce [0 pos 0x0]) thru newline]]
|
|---|
| 388 | f/origine-x: f/x * (1 + length? to string! length? head out)
|
|---|
| 389 | recycle/on
|
|---|
| 390 | out: head out
|
|---|
| 391 | ]
|
|---|
| 392 |
|
|---|
| 393 | ;** boxline: [pen red fill-pen red box 0x1 32x18]
|
|---|
| 394 |
|
|---|
| 395 | ;** debug: display where show occurs
|
|---|
| 396 | ;show: func [f][print either in f 'cursor ['area-tc]['cursor-only] system/words/show f]
|
|---|
| 397 |
|
|---|
| 398 | ;** markers used in replacement of the draw comman PUSH. Much easy to track them with parse.
|
|---|
| 399 | expand: ;** marker for info messages (like errors)
|
|---|
| 400 | hilight: 'push ;** marker for hilight background
|
|---|
| 401 | no-edit: ;** marker for text no editable
|
|---|
| 402 | edit: 'aliased
|
|---|
| 403 |
|
|---|
| 404 | ;** contruct draw blocks, only for new lines inserted
|
|---|
| 405 | set 'render-text func [
|
|---|
| 406 | f inc
|
|---|
| 407 | /stay
|
|---|
| 408 | /local pos char color draw-txt
|
|---|
| 409 | prev-col draw-sblk nb line data n decal
|
|---|
| 410 | ][
|
|---|
| 411 | start: now/precise
|
|---|
| 412 | prev-col: none
|
|---|
| 413 | case [
|
|---|
| 414 | stay [
|
|---|
| 415 | inc: inc - 1
|
|---|
| 416 | data: skip f/data inc
|
|---|
| 417 | ]
|
|---|
| 418 | inc < 0 [
|
|---|
| 419 | inc: negate min abs inc ((index? f/data) - 1)
|
|---|
| 420 | data: f/data: skip f/data inc
|
|---|
| 421 | ]
|
|---|
| 422 | inc > 0 [
|
|---|
| 423 | inc: min max 0 ((length? f/data) - f/nb-lines) inc
|
|---|
| 424 | data: f/data: skip f/data inc
|
|---|
| 425 | ]
|
|---|
| 426 | 'else [data: f/data]
|
|---|
| 427 | ]
|
|---|
| 428 |
|
|---|
| 429 | draw-txt: any [find f/effect/draw 'push tail f/effect/draw]
|
|---|
| 430 |
|
|---|
| 431 | case [
|
|---|
| 432 | stay [
|
|---|
| 433 | draw-txt: clear skip draw-txt max 0 inc * 4
|
|---|
| 434 | nb: min f/nb-lines f/nb-lines - inc
|
|---|
| 435 | ]
|
|---|
| 436 | empty? draw-txt [
|
|---|
| 437 | nb: f/nb-lines
|
|---|
| 438 | ]
|
|---|
| 439 | inc > 0 [
|
|---|
| 440 | remove/part draw-txt 4 * inc
|
|---|
| 441 | draw-txt: tail draw-txt
|
|---|
| 442 | nb: min f/nb-lines inc
|
|---|
| 443 | data: skip data either f/nb-lines > inc [f/nb-lines - inc][0]
|
|---|
| 444 | ;** A FAIRE, si inc d�passe le nombre de lignes affich�es,
|
|---|
| 445 | ;** parser les lignes skip�es (non affich�es)
|
|---|
| 446 | ;** pour d�tecter les strings multi-ligne
|
|---|
| 447 | ]
|
|---|
| 448 | inc < 0 [
|
|---|
| 449 | clear skip draw-txt max 0 4 * (f/nb-lines + inc)
|
|---|
| 450 | nb: min f/nb-lines abs inc
|
|---|
| 451 | ]
|
|---|
| 452 | 'else [return true]
|
|---|
| 453 | ]
|
|---|
| 454 | nb: min nb length? data
|
|---|
| 455 | n: 1
|
|---|
| 456 | decal: as-pair 0 f/y
|
|---|
| 457 | while [n <= nb][
|
|---|
| 458 | line: at data n
|
|---|
| 459 | draw-txt: insert draw-txt 'push
|
|---|
| 460 | draw-sblk: insert insert insert make block! 50
|
|---|
| 461 | [hilight none pen 128.128.128 text no-edit] as-pair f/xy/x 5
|
|---|
| 462 | reverse copy/part reverse head insert change
|
|---|
| 463 | clear "" " " (n - 1 + index? data) (f/origine-x - f/x / f/x)
|
|---|
| 464 | if colorize f line draw-sblk [
|
|---|
| 465 | decal: as-pair 0 2 * f/y
|
|---|
| 466 | ]
|
|---|
| 467 | draw-txt: insert insert insert/only draw-txt head draw-sblk 'translate decal
|
|---|
| 468 | decal: as-pair 0 f/y
|
|---|
| 469 | n: n + 1
|
|---|
| 470 | ]
|
|---|
| 471 |
|
|---|
| 472 | set-y f 5 ;** recalc all y offset of texts (which can be absolute only)
|
|---|
| 473 | unless f/cursor/selection? [show f]
|
|---|
| 474 | ;** probe difference now/precise start
|
|---|
| 475 | ]
|
|---|
| 476 |
|
|---|
| 477 | ;** recalc of all y offset after verstical scroll
|
|---|
| 478 | set-y: func [f y /local blk pair line idx gb lgb chg-y][
|
|---|
| 479 | blk: f/effect/draw
|
|---|
| 480 | blk: find f/effect/draw 'push
|
|---|
| 481 | lgb: index? f/data
|
|---|
| 482 | gb: f/cursor/global-idx
|
|---|
| 483 | idx: 2
|
|---|
| 484 | f/cursor/show?: false
|
|---|
| 485 | chg-y: [thru 'text ['edit | 'no-edit] pair: pair! (pair/1/y: y)]
|
|---|
| 486 | foreach [cmd value] blk [
|
|---|
| 487 | switch cmd [
|
|---|
| 488 | translate [y: y + value/y]
|
|---|
| 489 | push [
|
|---|
| 490 | if gb = lgb [
|
|---|
| 491 | f/cursor/xy/y: y
|
|---|
| 492 | f/cursor/data: at blk idx
|
|---|
| 493 | f/cursor/show?: true
|
|---|
| 494 | ]
|
|---|
| 495 | parse value [
|
|---|
| 496 | any chg-y
|
|---|
| 497 | any [thru 'push into [any chg-y to end break]]
|
|---|
| 498 | ]
|
|---|
| 499 | lgb: lgb + 1
|
|---|
| 500 | ]
|
|---|
| 501 |
|
|---|
| 502 | ]
|
|---|
| 503 | idx: idx + 2
|
|---|
| 504 | ]
|
|---|
| 505 | ]
|
|---|
| 506 |
|
|---|
| 507 | move-x: func [f x /local blk pair chg-x][
|
|---|
| 508 | blk: f/effect/draw
|
|---|
| 509 | blk: find f/effect/draw 'push
|
|---|
| 510 | chg-x: [thru 'text ['edit | 'no-edit] pair: pair! (pair/1/x: x + pair/1/x)]
|
|---|
| 511 | foreach [cmd value] blk [
|
|---|
| 512 | switch cmd [
|
|---|
| 513 | translate [x: x + value/x]
|
|---|
| 514 | push [
|
|---|
| 515 | parse value [
|
|---|
| 516 | any chg-x
|
|---|
| 517 | any [thru 'push into [any chg-x to end break]]
|
|---|
| 518 | ]
|
|---|
| 519 | ]
|
|---|
| 520 | ]
|
|---|
| 521 | ]
|
|---|
| 522 | f/cursor/xy/x: f/cursor/xy/x + x
|
|---|
| 523 | ]
|
|---|
| 524 |
|
|---|
| 525 |
|
|---|
| 526 | ;** return the inner face matching the point
|
|---|
| 527 | map-inner: func [face point /local pane][
|
|---|
| 528 | unless pane: face/pane [return face]
|
|---|
| 529 | unless block? pane [pane: to block! pane]
|
|---|
| 530 | foreach face pane [
|
|---|
| 531 | if within? point face/offset face/size [return map-inner face point - face/offset]
|
|---|
| 532 | ]
|
|---|
| 533 | face
|
|---|
| 534 | ]
|
|---|
| 535 |
|
|---|
| 536 | get*: func [v][do back change/only [none] v] ;** if v is a word, get value in the world
|
|---|
| 537 | any-char: complement space: charset " ^-"
|
|---|
| 538 |
|
|---|
| 539 | ;** find a free place in the whole area to display the info box
|
|---|
| 540 | find-free-places: func [
|
|---|
| 541 | f
|
|---|
| 542 | /local data end x len l-len r-pos stack-l stack-r
|
|---|
| 543 | ][
|
|---|
| 544 | stack-l: clear []
|
|---|
| 545 | stack-r: clear []
|
|---|
| 546 | data: f/data
|
|---|
| 547 | loop len: f/nb-lines [
|
|---|
| 548 | line: data/1/2
|
|---|
| 549 | end: any [find line newline tail line]
|
|---|
| 550 |
|
|---|
| 551 | ;** length of the left free zone
|
|---|
| 552 | pos: any [find/part line space end line]
|
|---|
| 553 | l-len: -1 + index? pos
|
|---|
| 554 |
|
|---|
| 555 | ;** start of the rigth free zone
|
|---|
| 556 | pos: ant [find/reverse end any-char end]
|
|---|
| 557 | r-start: index? pos
|
|---|
| 558 |
|
|---|
| 559 | stack-l: insert stack-l l-len
|
|---|
| 560 | stack-r: insert stack-r r-len
|
|---|
| 561 | data: next data
|
|---|
| 562 | ]
|
|---|
| 563 | x: maximum-of stack-l
|
|---|
| 564 | loop len [
|
|---|
| 565 |
|
|---|
| 566 | stack-l: next stack-l
|
|---|
| 567 | ]
|
|---|
| 568 | ]
|
|---|
| 569 |
|
|---|
| 570 | event-func: use [
|
|---|
| 571 | origin off-mem save-size 0x0 drag track
|
|---|
| 572 | ][
|
|---|
| 573 | origin: off-mem: save-size: 0x0
|
|---|
| 574 | drag: track: false
|
|---|
| 575 | func [
|
|---|
| 576 | {area-tc handler} ;** don't remove or change this text, it's used to identify the handler
|
|---|
| 577 | face event /local tmp
|
|---|
| 578 | ][
|
|---|
| 579 | ;**print [event/type event/key]
|
|---|
| 580 | switch event/type [
|
|---|
| 581 | time none ;** a lot of 'time events are sent, check it first
|
|---|
| 582 | key [
|
|---|
| 583 | ;** key handler for faces without text and caret (actually only for areat-tc)
|
|---|
| 584 | if event/1 = 'time [return event] ;** FUUUUUCK, why we receive that crap event here ???
|
|---|
| 585 | if all [
|
|---|
| 586 | tmp: system/view/focal-face
|
|---|
| 587 | in tmp 'style
|
|---|
| 588 | tmp/style = 'area-tc
|
|---|
| 589 | ][
|
|---|
| 590 | tmp/feel/engage tmp 'key event
|
|---|
| 591 | ]
|
|---|
| 592 | ]
|
|---|
| 593 | move [
|
|---|
| 594 | either drag [
|
|---|
| 595 | tmp: track/offset
|
|---|
| 596 | drag/feel/drag drag event/offset - origin
|
|---|
| 597 | origin: origin + track/offset - tmp ;** correct the origin, if the tracked face has moved
|
|---|
| 598 | return false ;** disable move event
|
|---|
| 599 | ][off-mem: event/offset ] ;** for mouse wheel motion
|
|---|
| 600 | ]
|
|---|
| 601 | resize [
|
|---|
| 602 | tmp: negate saved-size - saved-size: face/pane/1/size
|
|---|
| 603 | foreach face face/pane/1/pane [
|
|---|
| 604 | if in face/feel 'resize [face/feel/resize face tmp]
|
|---|
| 605 | ]
|
|---|
| 606 | ]
|
|---|
| 607 | down [
|
|---|
| 608 | face: map-inner event/face event/offset
|
|---|
| 609 | if in face/feel 'drag [
|
|---|
| 610 | ;** the draging face which contains the pointer may be different from the draged (track) face
|
|---|
| 611 | drag: face
|
|---|
| 612 | origin: event/offset
|
|---|
| 613 | track: drag/feel/drag/track drag event/offset
|
|---|
| 614 | ]
|
|---|
| 615 | ]
|
|---|
| 616 | up [if drag [recycle drag: false]]
|
|---|
| 617 | scroll-line [
|
|---|
| 618 | face: event/face
|
|---|
| 619 | face: map-inner event/face off-mem
|
|---|
| 620 | if in face/feel 'scrollwheel [
|
|---|
| 621 | face/feel/scrollwheel face event off-mem - win-offset? face
|
|---|
| 622 | ]
|
|---|
| 623 | ]
|
|---|
| 624 | active [saved-size: face/pane/1/size]
|
|---|
| 625 | ]
|
|---|
| 626 | ;**[print [event/type event/offset]]
|
|---|
| 627 | event
|
|---|
| 628 | ]
|
|---|
| 629 | ]
|
|---|
| 630 | key-to-insert: make bitset! #{
|
|---|
| 631 | 01000000FFFFFFFFFFFFFFFFFFFFFF7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
|
|---|
| 632 | }
|
|---|
| 633 |
|
|---|
| 634 | stylize/master [
|
|---|
| 635 |
|
|---|
| 636 | ; list of function widget
|
|---|
| 637 | func-view: box with [
|
|---|
| 638 | color: white
|
|---|
| 639 | edge: [ size: 1x1 color: 'black]
|
|---|
| 640 | feel: make feel [
|
|---|
| 641 | resize: func [f size+] [
|
|---|
| 642 | either pair? size+ [
|
|---|
| 643 | f/size/y: f/size/y + size+/y
|
|---|
| 644 | ][
|
|---|
| 645 | f/size: size+
|
|---|
| 646 | ]
|
|---|
| 647 | show f
|
|---|
| 648 | ]
|
|---|
| 649 | ]
|
|---|
| 650 | ;effect: make effect [ draw: []]
|
|---|
| 651 | draw-list: func [/local n nblines tmpstr line dr-blk pos] [
|
|---|
| 652 | nblines: length? f/data
|
|---|
| 653 | n: 1
|
|---|
| 654 | tmpstr: "" line: ""
|
|---|
| 655 | dr-blk: [pen 0.0.0]
|
|---|
| 656 | pos: 0x0
|
|---|
| 657 | while [n <= nblines][
|
|---|
| 658 | line: second f/data/:n
|
|---|
| 659 | line: copy/part line any [ find line newline tail line ] ; on ne prend que du debut de la ligne jusqu'au premier newline
|
|---|
| 660 | if not find line ";" [
|
|---|
| 661 | either find line any [": func" ": function" ": does" ": use" ": do" ] [
|
|---|
| 662 | ;probe line
|
|---|
| 663 | tmpstr: trim detab copy/part line find line ":"
|
|---|
| 664 |
|
|---|
| 665 | insert insert insert insert tail dr-blk 'text 'anti-aliased pos tmpstr
|
|---|
| 666 | pos: pos + 0x20
|
|---|
| 667 | ][
|
|---|
| 668 | if find line all ["set" "func"] [
|
|---|
| 669 | if not find line "!" [
|
|---|
| 670 | ;probe line
|
|---|
| 671 | tmpstr: trim detab copy/part line find line "func"
|
|---|
| 672 |
|
|---|
| 673 | insert insert insert insert tail dr-blk 'text 'anti-aliased pos tmpstr
|
|---|
| 674 | pos: pos + 0x20
|
|---|
| 675 | ]
|
|---|
| 676 | ]
|
|---|
| 677 | ]
|
|---|
| 678 | ]
|
|---|
| 679 | n: n + 1
|
|---|
| 680 | ]
|
|---|
| 681 | self/effect: compose/only [ draw (dr-blk) ]
|
|---|
| 682 | show self
|
|---|
| 683 | ;probe dr-blk
|
|---|
| 684 | ]
|
|---|
| 685 | ]
|
|---|
| 686 |
|
|---|
| 687 | ; arec text color
|
|---|
| 688 | area-tc: box with [
|
|---|
| 689 | style: 'area-tc
|
|---|
| 690 | rate: 1
|
|---|
| 691 | text: none
|
|---|
| 692 | para: make para [origin: 0x0 margin: 0x0]
|
|---|
| 693 | delay: 0
|
|---|
| 694 | ask: 'recycle ;** command to delay
|
|---|
| 695 | color: pref/bg_color
|
|---|
| 696 | x: 8 ;** current x size oh 1 char
|
|---|
| 697 | y: 18 ;** current y size of a line
|
|---|
| 698 | origine-x: 3 * x ;** stock la position a la quelle le texte d�marre apres le rendu des num�ro de ligne
|
|---|
| 699 | data: []
|
|---|
| 700 | font-obj: make face/font [name: "lucida console" size: 14 style: none offset: 0x0]
|
|---|
| 701 | nb-lines: 0
|
|---|
| 702 | xy: 0x0 ;** scroll offset
|
|---|
| 703 | move-offset: 0x0
|
|---|
| 704 | save-x: 0
|
|---|
| 705 | file-name: none
|
|---|
| 706 | effect: [draw [pen none font font-obj line-width 1 translate xy]]
|
|---|
| 707 | open-file: func [ file [file! none!] /local ][
|
|---|
| 708 | if any [file file: request-file ][
|
|---|
| 709 | ;** data: build-data detab/size read file 4 self
|
|---|
| 710 | if block? file [file: first file]
|
|---|
| 711 | data: build-data read/direct file self
|
|---|
| 712 | file-name: file
|
|---|
| 713 | render-text/stay t 1
|
|---|
| 714 | ]
|
|---|
| 715 | ]
|
|---|
| 716 | write-file: func [/local str-tmp n line nbline] [
|
|---|
| 717 | str-tmp: "" n: 1 nbline: length? data
|
|---|
| 718 | while [n <= nbline ] [
|
|---|
| 719 | line: second data/:n ; on transfert le pointeur vers le document dans data vers un autre pointeur
|
|---|
| 720 | append str-tmp copy/part line any [ find line newline tail line] ;on copy jusqu'a newline ou jusqu'a la fin
|
|---|
| 721 | append str-tmp newline
|
|---|
| 722 | n: n + 1
|
|---|
| 723 | ]
|
|---|
| 724 | write file-name str-tmp
|
|---|
| 725 | ]
|
|---|
| 726 | save-file: func [] [
|
|---|
| 727 | if 0 <> length? data [
|
|---|
| 728 | either none? file-name [ ; data is full but we don't have a file-name
|
|---|
| 729 | if file-name: request-file/save/title "Save as..." "save"
|
|---|
| 730 | [
|
|---|
| 731 | if block? file [file: first file]
|
|---|
| 732 | write-file ]
|
|---|
| 733 |
|
|---|
| 734 | ] [
|
|---|
| 735 | ; data is full and we have a file name
|
|---|
| 736 | write-file
|
|---|
| 737 | ]
|
|---|
| 738 | ]
|
|---|
| 739 | ]
|
|---|
| 740 | run_scr: func [] [
|
|---|
| 741 | save-file
|
|---|
| 742 | ;call/console rejoin [ pref/consol_path file-name ]
|
|---|
| 743 | launch file-name
|
|---|
| 744 | ]
|
|---|
| 745 |
|
|---|
| 746 | v-scroller: make face [
|
|---|
| 747 | offset: 0x0 size: 13x0 color: none edge: none
|
|---|
| 748 | size-box: 0x0
|
|---|
| 749 | para: none
|
|---|
| 750 | effect: [draw [pen sky line-width 2 fill-pen none box 0x0 size-box 2]]
|
|---|
| 751 | feel: make feel [
|
|---|
| 752 | redraw: func [f a /local p l][
|
|---|
| 753 | if all ['show = a p: f/parent-face 0 < l: length? head p/data][
|
|---|
| 754 | f/size/y: max 25 p/nb-lines / l * p/size/y
|
|---|
| 755 | f/offset/y: (index? p/data) / (l - p/nb-lines) * (p/size/y - f/size/y)
|
|---|
| 756 | f/size-box: f/size - 2x2
|
|---|
| 757 | ]
|
|---|
| 758 | ]
|
|---|
| 759 | drag: func [f offset /track /local coeff][
|
|---|
| 760 | f/parent-face/delay: 3 ;** don't perturb the scroll please
|
|---|
| 761 | if track [return f]
|
|---|
| 762 | if 1 <= abs coeff: offset/y / (f/size/y / f/parent-face/nb-lines) [
|
|---|
| 763 | render-text f/parent-face to integer! coeff
|
|---|
| 764 | if f/parent-face/cursor/selection? [
|
|---|
| 765 | f/parent-face/feel/expand-selector f/parent-face/cursor
|
|---|
| 766 | show f/parent-face
|
|---|
| 767 | ]
|
|---|
| 768 | ]
|
|---|
| 769 | ]
|
|---|
| 770 | engage: func [f a e][false] ;** don't send events to the area
|
|---|
| 771 | ]
|
|---|
| 772 | ]
|
|---|
| 773 | h-scroller: make face [
|
|---|
| 774 | offset: 0x0 size: 0x13 color: none edge: none
|
|---|
| 775 | size-box: 0x0
|
|---|
| 776 | text: none
|
|---|
| 777 | edge: none
|
|---|
| 778 | font: make font [align: 'right size: 10 style: 'bold color: red]
|
|---|
| 779 | para: make para [origin: 0x0]
|
|---|
| 780 | max-x: 1
|
|---|
| 781 | effect: [draw [pen sky line-width 2 fill-pen none box 0x0 size-box 2]]
|
|---|
| 782 | feel: make feel [
|
|---|
| 783 | redraw: func [f a /local parent][
|
|---|
| 784 | if 'show = a [
|
|---|
| 785 | f/show?: if f/max-x > f/parent-face/size/x [
|
|---|
| 786 | parent: f/parent-face
|
|---|
| 787 | f/offset/x: to integer! negate parent/xy/x / f/max-x * parent/size/x
|
|---|
| 788 | f/size/x: to integer! (parent/size/x ** 2) / f/max-x
|
|---|
| 789 | f/size-box: f/size - 2x2
|
|---|
| 790 | true
|
|---|
| 791 | ]
|
|---|
| 792 | ]
|
|---|
| 793 | ]
|
|---|
| 794 | drag: func [scroller offset /track /local parent save-x decal x][
|
|---|
| 795 | f: scroller/parent-face
|
|---|
| 796 | f/delay: 3 ;** don't perturb the scroll please
|
|---|
| 797 | if track [return scroller]
|
|---|
| 798 | if f/x <= abs offset/x [
|
|---|
| 799 | offset/x: to integer! offset/x + 4 / f/x * f/x
|
|---|
| 800 | save-x: f/xy/x
|
|---|
| 801 | x: f/xy/x: min 0 max
|
|---|
| 802 | f/size/x - scroller/max-x
|
|---|
| 803 | f/xy/x - offset/x
|
|---|
| 804 |
|
|---|
| 805 | ;** change change skip tail boxline -2
|
|---|
| 806 | ;** as-pair negate x 1 as-pair 32 - x 18
|
|---|
| 807 |
|
|---|
| 808 | if 0 <> decal: x - save-x [move-x f decal]
|
|---|
| 809 | show f
|
|---|
| 810 | ]
|
|---|
| 811 | ]
|
|---|
| 812 | engage: func [f a e][false] ;** don't send events to the area
|
|---|
| 813 | ]
|
|---|
| 814 | ]
|
|---|
| 815 | cursor: make face [
|
|---|
| 816 | offset: 0x5 size: 2x18 para: color: edge: none
|
|---|
| 817 | xy: as-pair origine-x 5
|
|---|
| 818 | sub-string: idx: global-idx: col: old-col:
|
|---|
| 819 | old-idx: tmp-offset: pos-len: old-pos-len: none
|
|---|
| 820 | selection?: false
|
|---|
| 821 | selector-xy: [0x0]
|
|---|
| 822 | head?: false
|
|---|
| 823 | data: pos-blk: []
|
|---|
| 824 | blink-color: red
|
|---|
| 825 | size-box: 2x16
|
|---|
| 826 | effect: [draw [pen blink-color fill-pen blink-color box 0x1 size-box]]
|
|---|
| 827 | feel: make feel [
|
|---|
| 828 | redraw: func [f a][
|
|---|
| 829 | if a = 'show [
|
|---|
| 830 | f/offset: f/xy
|
|---|
| 831 | if f/selection? [
|
|---|
| 832 | f/selector-xy/1/x: f/xy/x - f/parent-face/xy/x
|
|---|
| 833 | ]
|
|---|
| 834 | ]
|
|---|
| 835 | ]
|
|---|
| 836 | engage: func [f a e][] ;** disable events
|
|---|
| 837 | ]
|
|---|
| 838 | ]
|
|---|
| 839 | feel: make feel [
|
|---|
| 840 | scrollwheel: func [f event offset] [
|
|---|
| 841 | f/delay: 3
|
|---|
| 842 | dir: either event/offset/y > 0 ['down]['up]
|
|---|
| 843 | switch dir [
|
|---|
| 844 | down [render-text f 3]
|
|---|
| 845 | up [render-text f -3]
|
|---|
| 846 | ]
|
|---|
| 847 | if f/cursor/selection? [expand-selector f/cursor show f]
|
|---|
| 848 | ]
|
|---|
| 849 | resize: func [f size+][
|
|---|
| 850 | f/size: f/size + size+
|
|---|
| 851 | f/nb-lines: to-integer (f/size/y - 10 / f/y)
|
|---|
| 852 | f/v-scroller/offset: as-pair f/size/x - 13 2
|
|---|
| 853 | f/h-scroller/offset: as-pair 2 f/size/y - 13
|
|---|
| 854 | render-text/stay f 1
|
|---|
| 855 | if f/cursor/selection? [expand-selector f/cursor show f]
|
|---|
| 856 | ]
|
|---|
| 857 | begin-selection: func [
|
|---|
| 858 | cursor /local f
|
|---|
| 859 | ][
|
|---|
| 860 |
|
|---|
| 861 | f: cursor/parent-face
|
|---|
| 862 | cursor/selection?: true
|
|---|
| 863 | insert-selector f next cursor/data/1 cursor/xy/x + f/xy/x
|
|---|
| 864 | cursor/selector-xy: back tail cursor/data/1/2
|
|---|
| 865 | cursor/old-idx: cursor/global-idx
|
|---|
| 866 | cursor/old-pos-len: cursor/pos-len
|
|---|
| 867 | get-col cursor
|
|---|
| 868 | cursor/old-col: cursor/col
|
|---|
| 869 | ]
|
|---|
| 870 |
|
|---|
| 871 | ;** drag = activate selection
|
|---|
| 872 | drag: func [f offset /track /local cursor][
|
|---|
| 873 |
|
|---|
| 874 | ;** beware, it's the cursor which moves, not the area.
|
|---|
| 875 | if track [return f/cursor]
|
|---|
| 876 | unless f/cursor/selection? [begin-selection f/cursor]
|
|---|
| 877 |
|
|---|
| 878 | ;** not enough displacement to move the cursor
|
|---|
| 879 | if all [f/x > abs offset/x f/y > abs offset/y][exit]
|
|---|
| 880 |
|
|---|
| 881 | case [
|
|---|
| 882 | all [positive? offset/y f/cursor/idx = f/nb-lines][render-text f 1] ;** scroll down
|
|---|
| 883 | all [negative? offset/y f/cursor/idx = 1][render-text f -1] ;** scroll up
|
|---|
| 884 | ]
|
|---|
| 885 | click f f/cursor/xy + offset
|
|---|
| 886 | expand-selector f/cursor
|
|---|
| 887 | show f
|
|---|
| 888 | ]
|
|---|
| 889 |
|
|---|
| 890 | detect: func [f e][
|
|---|
| 891 | ;**print remold [e/1 e/2 e/3 e/4 e/5 e/6]
|
|---|
| 892 | if e/type = 'move [
|
|---|
| 893 | ;** because of the timer, 'move events are received, even if there is no move
|
|---|
| 894 | if all [find [info-position recycle] f/ask f/move-offset <> e/offset][
|
|---|
| 895 | f/ask: 'info-position
|
|---|
| 896 | f/delay: 2
|
|---|
| 897 | f/move-offset: e/offset
|
|---|
| 898 | ]
|
|---|
| 899 | return false
|
|---|
| 900 | ]
|
|---|
| 901 | e
|
|---|
| 902 | ]
|
|---|
| 903 | engage: func [f a e /local key tmp cursor select?][
|
|---|
| 904 | ;**print remold [a e/type e/key e/1 e/2 e/3 e/4 e/5 e/6]
|
|---|
| 905 | cursor: f/cursor
|
|---|
| 906 | if a = 'time [
|
|---|
| 907 | ;print [now/time f/ask f/delay]
|
|---|
| 908 | either all [cursor/show? find [recycle info-position] f/ask] [
|
|---|
| 909 | f/cursor/blink-color: get first reverse [red none]
|
|---|
| 910 | show f/cursor
|
|---|
| 911 | ][f/cursor/blink-color: red]
|
|---|
| 912 | case [
|
|---|
| 913 | 0 > f/delay: f/delay - 1 [
|
|---|
| 914 | ;** if f/ask <> 'show [print ["timer:" now/time f/ask] ]
|
|---|
| 915 | switch f/ask [
|
|---|
| 916 | show []
|
|---|
| 917 | recycle [recycle]
|
|---|
| 918 | ]
|
|---|
| 919 | f/ask: 'recycle
|
|---|
| 920 | f/rate: 1 ;** default rate, 1 event per second
|
|---|
| 921 | f/delay: 5 ;** recycle after 5 secs of inactivity
|
|---|
| 922 | show f ;** DON't remove the show here (needed to update the face rate)
|
|---|
| 923 | ]
|
|---|
| 924 | ]
|
|---|
| 925 | return false
|
|---|
| 926 | ]
|
|---|
| 927 | select?: cursor/selection?
|
|---|
| 928 | unless find [up down] key: e/key [f/save-x: 0]
|
|---|
| 929 | if f/ask <> 'show [f/ask: 'info-cursor f/delay: 3]
|
|---|
| 930 | cursor/blink-color: red
|
|---|
| 931 |
|
|---|
| 932 | if all [e/5 not select? any [word? key key < #" "]][
|
|---|
| 933 | select?: true
|
|---|
| 934 | begin-selection cursor
|
|---|
| 935 | ]
|
|---|
| 936 | switch a [
|
|---|
| 937 | down [click f e/offset]
|
|---|
| 938 | key [
|
|---|
| 939 | ;** e/6 = true for ctrl
|
|---|
| 940 | switch/default key[
|
|---|
| 941 | page-up [render-text f negate f/nb-lines]
|
|---|
| 942 | page-down [render-text f f/nb-lines]
|
|---|
| 943 | #"^P" [inc-font-size f 1] ;** increase font size
|
|---|
| 944 | #"^L" [inc-font-size f -1] ;** decrease font size
|
|---|
| 945 | #"^B" [bold f]
|
|---|
| 946 | ][
|
|---|
| 947 | locate-cursor cursor
|
|---|
| 948 | ]
|
|---|
| 949 | switch/default key [
|
|---|
| 950 | f1 [ if request "Run this Script ?" [ t/run_scr ] ]
|
|---|
| 951 | #"^M" [split-line f]
|
|---|
| 952 | #"^[" []
|
|---|
| 953 | #"^~" [ ;** delete
|
|---|
| 954 | either select? [
|
|---|
| 955 | do-selection/delete f
|
|---|
| 956 | ][
|
|---|
| 957 | delete-char cursor
|
|---|
| 958 | recolorize cursor
|
|---|
| 959 | ]
|
|---|
| 960 | show f
|
|---|
| 961 | ]
|
|---|
| 962 | #"^H" [ ;** backtab
|
|---|
| 963 | either select? [
|
|---|
| 964 | do-selection/delete f
|
|---|
| 965 | ][
|
|---|
| 966 | move-cursor/left cursor
|
|---|
| 967 | delete-char cursor
|
|---|
| 968 | recolorize cursor
|
|---|
| 969 | ]
|
|---|
| 970 | show f
|
|---|
| 971 | ]
|
|---|
| 972 | right [
|
|---|
| 973 | either e/6 [
|
|---|
| 974 | right-word cursor
|
|---|
| 975 | ][
|
|---|
| 976 | move-cursor/right cursor
|
|---|
| 977 | ]
|
|---|
| 978 | show cursor ]
|
|---|
| 979 | left [
|
|---|
| 980 | either e/6 [
|
|---|
| 981 | left-word cursor
|
|---|
| 982 | ][
|
|---|
| 983 | move-cursor/left cursor
|
|---|
| 984 | ]
|
|---|
| 985 | show cursor
|
|---|
| 986 | ]
|
|---|
| 987 | down [down-cursor cursor]
|
|---|
| 988 | up [up-cursor cursor]
|
|---|
| 989 | end [
|
|---|
| 990 | constraint f as-pair 100000 cursor/xy/y
|
|---|
| 991 | show cursor
|
|---|
| 992 | ]
|
|---|
| 993 | home [
|
|---|
| 994 | constraint f as-pair f/origine-x + f/xy/x cursor/xy/y
|
|---|
| 995 | show cursor
|
|---|
| 996 | ]
|
|---|
| 997 | #"^S" [ if request "Save file ? " [ f/save-file] ]
|
|---|
| 998 | #"^O" [ if request "Open a file?" [ f/open-file none]]
|
|---|
| 999 | #"^N" [ if request "Start a new file?" [f/data: build-data "" f render-text/stay f 1 ]]
|
|---|
| 1000 | #"^C" [do-selection/clip f]
|
|---|
| 1001 | #"^X" [do-selection/clip/delete f]
|
|---|
| 1002 | #"^V" [;** TO-DO insert multi-lines text
|
|---|
| 1003 | insert-char f/cursor tmp: first parse read clipboard:// "^/"
|
|---|
| 1004 | show f
|
|---|
| 1005 | ]
|
|---|
| 1006 | #"^F" [search f]
|
|---|
| 1007 |
|
|---|
| 1008 | ][
|
|---|
| 1009 | if all [char? key find key-to-insert key ][
|
|---|
| 1010 | insert-char f/cursor e/key
|
|---|
| 1011 | recolorize f/cursor
|
|---|
| 1012 | ;** auto-scroll horizontaly
|
|---|
| 1013 | if f/x * 10 + cursor/xy/x > f/size/x [
|
|---|
| 1014 | scroll-x f f/x * 10
|
|---|
| 1015 | ]
|
|---|
| 1016 | show f
|
|---|
| 1017 | ]
|
|---|
| 1018 | ]
|
|---|
| 1019 | ]
|
|---|
| 1020 | ]
|
|---|
| 1021 | if select? [
|
|---|
| 1022 | either any [e/5 e/6 a = 'up] [
|
|---|
| 1023 | expand-selector cursor
|
|---|
| 1024 | ][
|
|---|
| 1025 | remove-selector cursor
|
|---|
| 1026 | ]
|
|---|
| 1027 | show f
|
|---|
| 1028 | ]
|
|---|
| 1029 | ]
|
|---|
| 1030 | bold: func [f][
|
|---|
| 1031 | f/font-obj/style: either f/font-obj/style [none]['bold]
|
|---|
| 1032 | inc-font-size f 0
|
|---|
| 1033 | ]
|
|---|
| 1034 | search: func [f][
|
|---|
| 1035 | ;what: read clipboard://
|
|---|
| 1036 | ]
|
|---|
| 1037 |
|
|---|
| 1038 | split-line: func [f /local tmp str blanks][
|
|---|
| 1039 | insert-char f/cursor "^/"
|
|---|
| 1040 |
|
|---|
| 1041 | tmp: at f/data f/cursor/idx
|
|---|
| 1042 | str: tmp/1/2
|
|---|
| 1043 |
|
|---|
| 1044 | blanks: copy/part str find str any-char
|
|---|
| 1045 | insert str: find/tail str newline blanks
|
|---|
| 1046 | insert/only next tmp reduce [0 str 0x0]
|
|---|
| 1047 |
|
|---|
| 1048 | render-text/stay f f/cursor/idx
|
|---|
| 1049 | replace/all blanks tab " "
|
|---|
| 1050 | f/cursor/xy/x: f/origine-x + f/xy/x + (f/x * length? blanks)
|
|---|
| 1051 | down-cursor f/cursor
|
|---|
| 1052 | f/save-x: 0
|
|---|
| 1053 | ]
|
|---|
| 1054 |
|
|---|
| 1055 | inc-font-size: func [f inc /local tmp][
|
|---|
| 1056 |
|
|---|
| 1057 | f/font-obj/size: max 10 min 30 f/font-obj/size + inc
|
|---|
| 1058 | f/origine-x: f/origine-x / f/x
|
|---|
| 1059 | f/xy/x: f/xy/x / f/x
|
|---|
| 1060 | tmp: size-text make face [
|
|---|
| 1061 | text: "MM"
|
|---|
| 1062 | size: 300x300
|
|---|
| 1063 | font: f/font-obj
|
|---|
| 1064 | para: f/para
|
|---|
| 1065 | ]
|
|---|
| 1066 | f/x: to integer! tmp/x / 2
|
|---|
| 1067 | f/y: tmp/y + 2
|
|---|
| 1068 | f/xy/x: f/xy/x * f/x
|
|---|
| 1069 | f/origine-x: f/origine-x * f/x
|
|---|
| 1070 | f/cursor/size/y: f/y
|
|---|
| 1071 | f/cursor/size-box/y: f/y - 2
|
|---|
| 1072 | tmp: f/cursor/xy
|
|---|
| 1073 | resize f 0
|
|---|
| 1074 | click f tmp
|
|---|
| 1075 | ]
|
|---|
| 1076 |
|
|---|
| 1077 | do-selection: func [
|
|---|
| 1078 | f
|
|---|
| 1079 | /delete /clip
|
|---|
| 1080 | /local cursor data idx old-idx start end str start-col end-col scroll n y
|
|---|
| 1081 | ][
|
|---|
| 1082 | cursor: f/cursor
|
|---|
| 1083 | if clip [clip: make string! 256]
|
|---|
| 1084 | idx: cursor/global-idx
|
|---|
| 1085 | old-idx: cursor/old-idx
|
|---|
| 1086 | get-col cursor
|
|---|
| 1087 | either old-idx < idx [
|
|---|
| 1088 | set [start end] reduce [old-idx idx]
|
|---|
| 1089 | set [start-col end-col] reduce [cursor/old-col cursor/col]
|
|---|
| 1090 | either start < index? f/data [
|
|---|
| 1091 | scroll: start - index? f/data
|
|---|
| 1092 | n: -1 + min start to-integer f/nb-lines / 2
|
|---|
| 1093 | scroll: scroll - n
|
|---|
| 1094 | y: n * f/y + 2
|
|---|
| 1095 | ][
|
|---|
| 1096 | y: cursor/xy/y +(start - end * f/y)
|
|---|
| 1097 | ]
|
|---|
| 1098 | ][
|
|---|
| 1099 | set [start end] reduce [idx old-idx]
|
|---|
| 1100 | set [start-col end-col] reduce [cursor/col cursor/old-col]
|
|---|
| 1101 | ]
|
|---|
| 1102 | data: at head f/data start
|
|---|
| 1103 | if start = end [
|
|---|
| 1104 | set [start-col end-col] sort reduce [start-col end-col]
|
|---|
| 1105 | ]
|
|---|
| 1106 | if delete [
|
|---|
| 1107 | locate-cursor cursor
|
|---|
| 1108 | delete: copy/part data/1/2 start-col - 1
|
|---|
| 1109 | ]
|
|---|
| 1110 | loop end - start [
|
|---|
| 1111 | if clip [
|
|---|
| 1112 | append clip append copy/part at data/1/2 start-col
|
|---|
| 1113 | any [find data/1/2 newline tail data/1/2]
|
|---|
| 1114 | newline
|
|---|
| 1115 |
|
|---|
| 1116 | ]
|
|---|
| 1117 | either delete [remove data][data: next data]
|
|---|
| 1118 | start-col: 1
|
|---|
| 1119 | ]
|
|---|
| 1120 |
|
|---|
| 1121 | str: data/1/2
|
|---|
| 1122 | case/all [
|
|---|
| 1123 | clip [
|
|---|
| 1124 | append clip copy/part at str start-col at str end-col
|
|---|
| 1125 | write clipboard:// clip
|
|---|
| 1126 | clip: none
|
|---|
| 1127 | ]
|
|---|
| 1128 | delete [
|
|---|
| 1129 | data/1/2: delete
|
|---|
| 1130 | case [
|
|---|
| 1131 | scroll [render-text f scroll]
|
|---|
| 1132 | start <> end [render-text/stay f 1]
|
|---|
| 1133 | 'else [recolorize cursor]
|
|---|
| 1134 | ]
|
|---|
| 1135 | if y [cursor/xy/y: y]
|
|---|
| 1136 | constraint f cursor/xy
|
|---|
| 1137 | append delete copy/part at str end-col any [find str newline tail str]
|
|---|
| 1138 | recolorize cursor
|
|---|
| 1139 | ]
|
|---|
| 1140 | ]
|
|---|
| 1141 | ]
|
|---|
| 1142 |
|
|---|
| 1143 | click: func [f offset][
|
|---|
| 1144 | ;** We don't use the focus function to avoid this dummy system caret (whe have our own)
|
|---|
| 1145 | unless same? system/view/focal-face f [
|
|---|
| 1146 | if system/view/focal-face [unfocus]
|
|---|
| 1147 | system/view/focal-face: f
|
|---|
| 1148 | ]
|
|---|
| 1149 |
|
|---|
| 1150 | constraint f either offset/x - f/xy/x < f/origine-x
|
|---|
| 1151 | [as-pair f/origine-x offset/y][offset]
|
|---|
| 1152 | show f/cursor
|
|---|
| 1153 | ]
|
|---|
| 1154 | expand-selector: func [
|
|---|
| 1155 | cursor
|
|---|
| 1156 | /local idx f pos curr-idx add-selector del-selector upd-selector str
|
|---|
| 1157 | x upd-tail upd-head add-tail add-head calc-tail add-middle upd-middle old-idx
|
|---|
| 1158 | ][
|
|---|
| 1159 |
|
|---|
| 1160 | f: cursor/parent-face
|
|---|
| 1161 | idx: cursor/global-idx
|
|---|
| 1162 | old-idx: cursor/old-idx
|
|---|
| 1163 | curr-idx: index? f/data
|
|---|
| 1164 | del-selector: [change pos none]
|
|---|
| 1165 | calc-tail: [
|
|---|
| 1166 | x: 0
|
|---|
| 1167 | parse pos [some [
|
|---|
| 1168 | thru 'text skip pair! [set str string! | set str word! (str: get str)]
|
|---|
| 1169 | (x: x + length? str)
|
|---|
| 1170 | ]]
|
|---|
| 1171 | x: x + 1 * f/x
|
|---|
| 1172 | ]
|
|---|
| 1173 | upd-middle: [cursor/selector-xy: back tail pos/1]
|
|---|
| 1174 | upd-tail: [do calc-tail change back tail pos/1 as-pair x f/y + 7]
|
|---|
| 1175 | upd-head: [change back tail pos/1 as-pair f/origine-x f/y + 7]
|
|---|
| 1176 | add-head: [insert-selector f pos f/origine-x]
|
|---|
| 1177 | add-tail: [do calc-tail insert-selector f pos x]
|
|---|
| 1178 | add-middle: [print "Beginning of the selection lost, TO DO !!!"]
|
|---|
| 1179 |
|
|---|
| 1180 | upd-selector: [(
|
|---|
| 1181 | either old-idx < idx [
|
|---|
| 1182 | case [
|
|---|
| 1183 | curr-idx < old-idx del-selector
|
|---|
| 1184 | curr-idx > idx del-selector
|
|---|
| 1185 | curr-idx = idx upd-middle ;** cover until the position of the cursor
|
|---|
| 1186 | 'else upd-tail ;** cover the tail of the line
|
|---|
| 1187 | ]
|
|---|
| 1188 | ][
|
|---|
| 1189 | case [
|
|---|
| 1190 | curr-idx < idx del-selector
|
|---|
| 1191 | curr-idx > old-idx del-selector
|
|---|
| 1192 | curr-idx = idx upd-middle ;** cover until the position of the cursor
|
|---|
| 1193 | 'else upd-head ;** cover the head of the line
|
|---|
| 1194 | ]
|
|---|
| 1195 | ]
|
|---|
| 1196 | curr-idx: curr-idx + 1
|
|---|
| 1197 | )]
|
|---|
| 1198 |
|
|---|
| 1199 | add-selector: [(
|
|---|
| 1200 | either old-idx < idx [
|
|---|
| 1201 | case [
|
|---|
| 1202 | curr-idx < old-idx none
|
|---|
| 1203 | curr-idx > idx none
|
|---|
| 1204 | curr-idx = idx [do add-head do upd-middle] ;** cover tail
|
|---|
| 1205 | curr-idx = old-idx [do add-middle 'do upd-tail];** cover middle to tail
|
|---|
| 1206 | 'else [do add-head do upd-tail] ;** cover the whole line
|
|---|
| 1207 | ]
|
|---|
| 1208 | ][
|
|---|
| 1209 | case [
|
|---|
| 1210 | curr-idx < idx none
|
|---|
| 1211 | curr-idx > old-idx none
|
|---|
| 1212 | curr-idx = idx [do add-tail do upd-middle] ;** cover tail
|
|---|
| 1213 | curr-idx = old-idx [do add-middle 'do upd-head];** cover middle to head
|
|---|
| 1214 | 'else [do add-tail do upd-head] ;** cover the whole line
|
|---|
| 1215 | ]
|
|---|
| 1216 | ]
|
|---|
| 1217 | curr-idx: curr-idx + 1
|
|---|
| 1218 | )]
|
|---|
| 1219 |
|
|---|
| 1220 | parse f/effect/draw [
|
|---|
| 1221 | any [
|
|---|
| 1222 | thru 'push into ['hilight pos: [block! upd-selector | add-selector ] to end]
|
|---|
| 1223 | ]
|
|---|
| 1224 | ]
|
|---|
| 1225 | ]
|
|---|
| 1226 | insert-selector: func [f where x][
|
|---|
| 1227 | ;** append an highlight box in the current block at relative x position
|
|---|
| 1228 | change/only where
|
|---|
| 1229 | compose [pen 255.200.10 fill-pen 250.200.10 box (as-pair x 7) (as-pair x f/y + 7)]
|
|---|
| 1230 | ]
|
|---|
| 1231 | remove-selector: func [cursor /local f tmp][
|
|---|
| 1232 | cursor/selection?: false
|
|---|
| 1233 | parse cursor/parent-face/effect/draw [
|
|---|
| 1234 | any [thru 'push into ['hilight tmp: (change tmp none) to end]]
|
|---|
| 1235 | ]
|
|---|
| 1236 | ]
|
|---|
| 1237 | left-word: func [cursor /local f x str blk pos s-blk][
|
|---|
| 1238 | f: cursor/parent-face
|
|---|
| 1239 | str: get-sub-string cursor
|
|---|
| 1240 | blk: skip s-blk: cursor/pos-blk -2
|
|---|
| 1241 |
|
|---|
| 1242 | case [
|
|---|
| 1243 | find/reverse blk 'edit none ;** not head of line
|
|---|
| 1244 | not head? str none ;** neither
|
|---|
| 1245 | 'else [
|
|---|
| 1246 | cursor/xy/x: 100000
|
|---|
| 1247 | if up-cursor cursor [left-word cursor]
|
|---|
| 1248 | exit
|
|---|
| 1249 | ]
|
|---|
| 1250 | ]
|
|---|
| 1251 | x: 0
|
|---|
| 1252 | foreach stuff reduce [any-char space][
|
|---|
| 1253 | while [
|
|---|
| 1254 | all [
|
|---|
| 1255 | not find/reverse str stuff
|
|---|
| 1256 | blk
|
|---|
| 1257 | blk: find/reverse blk 'edit
|
|---|
| 1258 | ]
|
|---|
| 1259 | ][
|
|---|
| 1260 | x: x - 1 + index? str
|
|---|
| 1261 | str: tail get* blk/3
|
|---|
| 1262 | ]
|
|---|
| 1263 | x: x - length? str
|
|---|
| 1264 | str: any [find/reverse str stuff str]
|
|---|
| 1265 | x: x + length? str
|
|---|
| 1266 | ]
|
|---|
| 1267 | either str/1 = #" " [x: x - 1][x: x + (index? str) - index? head str]
|
|---|
| 1268 | if x = 0 [x: -1 + index? str]
|
|---|
| 1269 | constraint f cursor/xy + as-pair x * negate f/x 0
|
|---|
| 1270 | ]
|
|---|
| 1271 |
|
|---|
| 1272 | get-sub-string: func [cursor][
|
|---|
| 1273 | at head do back change [none] cursor/sub-string cursor/pos-len
|
|---|
| 1274 | ]
|
|---|
| 1275 |
|
|---|
| 1276 | right-word: func [cursor /local x str blk pos][
|
|---|
| 1277 | f: cursor/parent-face
|
|---|
| 1278 | blk: s-blk: cursor/pos-blk
|
|---|
| 1279 | str: get-sub-string cursor
|
|---|
| 1280 |
|
|---|
| 1281 | case [
|
|---|
| 1282 | find blk 'edit none ;** not tail of line
|
|---|
| 1283 | not tail? str none ;** neither
|
|---|
| 1284 | 'else [
|
|---|
| 1285 | cursor/xy/x: f/origine-x + f/xy/x
|
|---|
| 1286 | if down-cursor cursor [right-word cursor]
|
|---|
| 1287 | exit
|
|---|
| 1288 | ]
|
|---|
| 1289 | ]
|
|---|
| 1290 | x: 0
|
|---|
| 1291 | foreach stuff reduce [space any-char][
|
|---|
| 1292 | while [
|
|---|
| 1293 | all [
|
|---|
| 1294 | not find str stuff
|
|---|
| 1295 | blk
|
|---|
| 1296 | blk: find/tail blk 'edit
|
|---|
| 1297 | ]
|
|---|
| 1298 | ][
|
|---|
| 1299 | x: x + length? str
|
|---|
| 1300 | str: get* blk/2
|
|---|
| 1301 | ]
|
|---|
| 1302 | x: x - index? str
|
|---|
| 1303 | str: any [find str stuff str]
|
|---|
| 1304 | x: x + index? str
|
|---|
| 1305 | ]
|
|---|
| 1306 | if str/1 = #" " [x: x + length? str]
|
|---|
| 1307 | if x = 0 [x: length? str]
|
|---|
| 1308 | constraint f cursor/xy + as-pair x * f/x 0
|
|---|
| 1309 | ]
|
|---|
| 1310 |
|
|---|
| 1311 | scroll-x: func [f x][
|
|---|
| 1312 | f/h-scroller/feel/drag f/h-scroller as-pair x 0
|
|---|
| 1313 | ]
|
|---|
| 1314 |
|
|---|
| 1315 | locate-cursor: func [cursor /local x idx f][
|
|---|
| 1316 | f: cursor/parent-face
|
|---|
| 1317 | unless cursor/show? [
|
|---|
| 1318 | either (idx: cursor/global-idx) < index? f/data [
|
|---|
| 1319 | render-text f idx - index? f/data
|
|---|
| 1320 | ][
|
|---|
| 1321 | render-text f idx - f/nb-lines + 1 - index? f/data
|
|---|
| 1322 | ]
|
|---|
| 1323 | ]
|
|---|
| 1324 | x: cursor/xy/x
|
|---|
| 1325 | if any [
|
|---|
| 1326 | x > (f/size/x - f/x)
|
|---|
| 1327 | x < f/x
|
|---|
| 1328 | ][scroll-x f f/x * 20 + f/xy/x + cursor/xy/x - f/size/x ]
|
|---|
| 1329 | ]
|
|---|
| 1330 |
|
|---|
| 1331 |
|
|---|
| 1332 | move-cursor: func [
|
|---|
| 1333 | cursor
|
|---|
| 1334 | /left /right
|
|---|
| 1335 | /local f pos offset len
|
|---|
| 1336 | ][
|
|---|
| 1337 | f: cursor/parent-face
|
|---|
| 1338 | ;** locate-cursor cursor
|
|---|
| 1339 | ;** print remold [cursor/pos-len cursor/sub-string]
|
|---|
| 1340 | case [
|
|---|
| 1341 | left [
|
|---|
| 1342 | if len: either string? cursor/sub-string [
|
|---|
| 1343 | either cursor/pos-len = 1 [1][
|
|---|
| 1344 | cursor/pos-len: cursor/pos-len - 1
|
|---|
| 1345 | cursor/sub-string: back cursor/sub-string
|
|---|
| 1346 | cursor/xy/x: cursor/xy/x - f/x
|
|---|
| 1347 | false
|
|---|
| 1348 | ]
|
|---|
| 1349 | ][
|
|---|
| 1350 | either cursor/pos-len = 1 [1][
|
|---|
| 1351 | cursor/pos-len: 1
|
|---|
| 1352 | cursor/xy/x: cursor/xy/x - (f/x * length? get cursor/sub-string)
|
|---|
| 1353 | false
|
|---|
| 1354 | ]
|
|---|
| 1355 | ][
|
|---|
| 1356 | either pos: find/tail/reverse skip cursor/pos-blk -2 'edit [
|
|---|
| 1357 | either string? pos/2 [
|
|---|
| 1358 | len: length? pos/2
|
|---|
| 1359 | cursor/sub-string: at pos/2 len
|
|---|
| 1360 | ][
|
|---|
| 1361 | cursor/sub-string: pos/2
|
|---|
| 1362 | ]
|
|---|
| 1363 | cursor/pos-len: len
|
|---|
| 1364 | cursor/xy/x: pos/1/1 + (len - 1 * f/x)
|
|---|
| 1365 | cursor/pos-blk: skip pos 1
|
|---|
| 1366 | ][
|
|---|
| 1367 | if cursor/global-idx > 1 [
|
|---|
| 1368 | cursor/xy/x: 100000
|
|---|
| 1369 | up-cursor cursor
|
|---|
| 1370 | ]
|
|---|
| 1371 | ]
|
|---|
| 1372 | ]
|
|---|
| 1373 | ]
|
|---|
| 1374 | right [
|
|---|
| 1375 | if len: either string? cursor/sub-string [
|
|---|
| 1376 | either tail? cursor/sub-string [2][
|
|---|
| 1377 | cursor/pos-len: cursor/pos-len + 1
|
|---|
| 1378 | cursor/sub-string: next cursor/sub-string
|
|---|
| 1379 | cursor/xy/x: cursor/xy/x + f/x
|
|---|
| 1380 | false
|
|---|
| 1381 | ]
|
|---|
| 1382 | ][
|
|---|
| 1383 | either cursor/pos-len > 1 [2][
|
|---|
| 1384 | cursor/pos-len: 1 + length? get cursor/sub-string
|
|---|
| 1385 | cursor/xy/x: cursor/xy/x + (f/x * length? get cursor/sub-string)
|
|---|
| 1386 | false
|
|---|
| 1387 | ]
|
|---|
| 1388 | ][
|
|---|
| 1389 | either pos: find/tail cursor/pos-blk 'edit [
|
|---|
| 1390 | either string? pos/2 [
|
|---|
| 1391 | cursor/sub-string: at pos/2 len
|
|---|
| 1392 | ][
|
|---|
| 1393 | len: 1 + length? get pos/2
|
|---|
| 1394 | cursor/sub-string: pos/2
|
|---|
| 1395 | ]
|
|---|
| 1396 | cursor/pos-len: len
|
|---|
| 1397 | cursor/xy/x: pos/1/1 + (len - 1 * f/x)
|
|---|
| 1398 | cursor/pos-blk: skip pos 1
|
|---|
| 1399 | ][
|
|---|
| 1400 | if cursor/global-idx < index? back tail f/data [
|
|---|
| 1401 | cursor/xy/x: f/origine-x + f/xy/x
|
|---|
| 1402 | down-cursor cursor
|
|---|
| 1403 | ]
|
|---|
| 1404 | ]
|
|---|
| 1405 | ]
|
|---|
| 1406 | ]
|
|---|
| 1407 | ]
|
|---|
| 1408 | ]
|
|---|
| 1409 | delay-show: func [f][
|
|---|
| 1410 | f/ask: 'show ;** delay the show event, speed issue
|
|---|
| 1411 | f/delay: 1 ; wait 2 checks
|
|---|
| 1412 | f/rate: 10 ; check 10 times per second
|
|---|
| 1413 | ]
|
|---|
| 1414 | down-cursor: func [cursor /local f tmp][
|
|---|
| 1415 | f: cursor/parent-face
|
|---|
| 1416 | if cursor/global-idx < index? back tail f/data [
|
|---|
| 1417 | if cursor/idx = f/nb-lines [
|
|---|
| 1418 | delay-show f
|
|---|
| 1419 | render-text f 1
|
|---|
| 1420 | ]
|
|---|
| 1421 | tmp: cursor/xy + third cursor/data
|
|---|
| 1422 | if f/save-x = 0 [f/save-x: tmp/x]
|
|---|
| 1423 | constraint f as-pair f/save-x tmp/y
|
|---|
| 1424 | unless f/ask = 'show [show cursor]
|
|---|
| 1425 | true
|
|---|
| 1426 | ]
|
|---|
| 1427 | ]
|
|---|
| 1428 | up-cursor: func [cursor /local f tmp][
|
|---|
| 1429 | f: cursor/parent-face
|
|---|
| 1430 | if cursor/global-idx > 1 [
|
|---|
| 1431 | if cursor/idx = 1 [
|
|---|
| 1432 | delay-show f
|
|---|
| 1433 | render-text f -1
|
|---|
| 1434 | ]
|
|---|
| 1435 | tmp: cursor/xy - pick cursor/data -2
|
|---|
| 1436 | if f/save-x = 0 [f/save-x: tmp/x]
|
|---|
| 1437 | constraint f as-pair f/save-x tmp/y
|
|---|
| 1438 | unless f/ask = 'show [show cursor]
|
|---|
| 1439 | true
|
|---|
| 1440 | ]
|
|---|
| 1441 | ]
|
|---|
| 1442 |
|
|---|
| 1443 | insert-char: func [cursor char /local f text refresh?][
|
|---|
| 1444 | f: cursor/parent-face
|
|---|
| 1445 | if cursor/selection? [
|
|---|
| 1446 | do-selection/delete f
|
|---|
| 1447 | locate-cursor cursor
|
|---|
| 1448 | refresh?: true
|
|---|
| 1449 | ]
|
|---|
| 1450 | text: cursor/sub-string
|
|---|
| 1451 | either string? text [
|
|---|
| 1452 | insert text char
|
|---|
| 1453 | ][
|
|---|
| 1454 | insert insert
|
|---|
| 1455 | either cursor/pos-len = 1 [cursor/pos-blk][next cursor/pos-blk]
|
|---|
| 1456 | 'new
|
|---|
| 1457 | char
|
|---|
| 1458 | ]
|
|---|
| 1459 | collect cursor
|
|---|
| 1460 | cursor/xy/x: cursor/xy/x + either char = tab [4 * f/x][f/x * length? form char]
|
|---|
| 1461 | if refresh? [
|
|---|
| 1462 | render-text/stay f 1
|
|---|
| 1463 | constraint f cursor/xy
|
|---|
| 1464 | ]
|
|---|
| 1465 | ]
|
|---|
| 1466 |
|
|---|
| 1467 | delete-char: func [cursor /local pos f data str1 str2 end][
|
|---|
| 1468 | text: cursor/sub-string
|
|---|
| 1469 | unless either string? text [
|
|---|
| 1470 | unless tail? text [remove text]
|
|---|
| 1471 | ][
|
|---|
| 1472 | if cursor/pos-len = 1 [remove back cursor/pos-blk] ;**remove the offset
|
|---|
| 1473 | ][
|
|---|
| 1474 | either pos: find/tail cursor/pos-blk 'edit [
|
|---|
| 1475 | either string? pos/2 [
|
|---|
| 1476 | remove pos/2
|
|---|
| 1477 | ][
|
|---|
| 1478 | remove pos ;** remove the offset
|
|---|
| 1479 | ]
|
|---|
| 1480 | ][
|
|---|
| 1481 | regroup-2-lines cursor
|
|---|
| 1482 | exit
|
|---|
| 1483 | ]
|
|---|
| 1484 | ]
|
|---|
| 1485 |
|
|---|
| 1486 | collect cursor
|
|---|
| 1487 | ]
|
|---|
| 1488 | get-col: func [cursor /local col pos][
|
|---|
| 1489 | col: 0
|
|---|
| 1490 | pos: cursor/data/1
|
|---|
| 1491 | while [pos: find/tail pos 'edit][
|
|---|
| 1492 | if same? pos: next pos cursor/pos-blk [break]
|
|---|
| 1493 | col: col + either string? pos/1 [length? head pos/1][1]
|
|---|
| 1494 | ]
|
|---|
| 1495 | col: col + either string? cursor/sub-string
|
|---|
| 1496 | [cursor/pos-len]
|
|---|
| 1497 | [either cursor/pos-len > 1 [2][1]]
|
|---|
| 1498 | cursor/col: col
|
|---|
| 1499 | ]
|
|---|
| 1500 |
|
|---|
| 1501 | collect: func [cursor /local full txt pos][
|
|---|
| 1502 | full: clear {}
|
|---|
| 1503 | add-full: [(full: insert full either word? txt [#"^-"][txt])]
|
|---|
| 1504 | parse cursor/data/1 [
|
|---|
| 1505 | any [thru 'edit opt [
|
|---|
| 1506 | pair!
|
|---|
| 1507 | opt ['new set txt skip add-full]
|
|---|
| 1508 | set txt skip add-full
|
|---|
| 1509 | opt ['new set txt skip add-full]
|
|---|
| 1510 | ]]
|
|---|
| 1511 | ]
|
|---|
| 1512 | poke first at cursor/parent-face/data cursor/idx 2 copy head full
|
|---|
| 1513 | ]
|
|---|
| 1514 | regroup-2-lines: func [cursor][
|
|---|
| 1515 | f: cursor/parent-face
|
|---|
| 1516 | data: at head f/data cursor/global-idx
|
|---|
| 1517 | unless tail? next data [
|
|---|
| 1518 | str1: either end: find data/1/2 newline [copy/part data/1/2 end][data/1/2]
|
|---|
| 1519 | str2: either end: find data/2/2 newline [copy/part data/2/2 end][data/2/2]
|
|---|
| 1520 | append str1 str2
|
|---|
| 1521 | poke data/1 2 str1
|
|---|
| 1522 | remove next data
|
|---|
| 1523 | render-text/stay f cursor/idx
|
|---|
| 1524 | ]
|
|---|
| 1525 | ]
|
|---|
| 1526 |
|
|---|
| 1527 | ;*** Reconstruct a line (draw block) after an insert
|
|---|
| 1528 | ;*** (which contains modified sub-strings)
|
|---|
| 1529 | ;* if the line contains a multi-line string, then other lines below
|
|---|
| 1530 | ;* may be reconstructed too.
|
|---|
| 1531 | recolorize: func [
|
|---|
| 1532 | cursor
|
|---|
| 1533 | /local line f multi-p multi data pos-head
|
|---|
| 1534 | ][
|
|---|
| 1535 | f: cursor/parent-face
|
|---|
| 1536 | data: cursor/data
|
|---|
| 1537 | line: at f/data cursor/idx
|
|---|
| 1538 |
|
|---|
| 1539 | change skip data 2
|
|---|
| 1540 | either colorize f line clear find/tail data/1 string!
|
|---|
| 1541 | [as-pair 0 2 * f/y][as-pair 0 f/y]
|
|---|
| 1542 |
|
|---|
| 1543 | loop f/nb-lines - cursor/idx [
|
|---|
| 1544 | if tail? next line [break]
|
|---|
| 1545 |
|
|---|
| 1546 | multi-p: line/1/1
|
|---|
| 1547 | multi: line/2/1
|
|---|
| 1548 | if any [
|
|---|
| 1549 | all [find [1 2] multi-p find [1 3] multi]
|
|---|
| 1550 | all [find [3 4] multi-p find [2 4] multi]
|
|---|
| 1551 | ][break]
|
|---|
| 1552 |
|
|---|
| 1553 | data: find/tail data 'push
|
|---|
| 1554 | line: next line
|
|---|
| 1555 | change skip data 2
|
|---|
| 1556 | either colorize f line clear find/tail data/1 string!
|
|---|
| 1557 | [as-pair 0 2 * f/y][as-pair 0 f/y]
|
|---|
| 1558 | ]
|
|---|
| 1559 | constraint f cursor/xy
|
|---|
| 1560 | set-y f 5
|
|---|
| 1561 | ]
|
|---|
| 1562 |
|
|---|
| 1563 | constraint: func [
|
|---|
| 1564 | f offset
|
|---|
| 1565 | /local cursor y blk pair text cont? idx save-pair at-tail? len
|
|---|
| 1566 | ][
|
|---|
| 1567 | y: idx: 0
|
|---|
| 1568 | cont?: none
|
|---|
| 1569 | cursor: f/cursor
|
|---|
| 1570 | at-tail?: false
|
|---|
| 1571 | parse f/effect/draw [
|
|---|
| 1572 | some [
|
|---|
| 1573 | thru 'push blk: block! skip set pair pair!
|
|---|
| 1574 | (idx: idx + 1 cont?: if offset/y <= (y + pair/y) ['break])
|
|---|
| 1575 | cont? (y: y + pair/y)
|
|---|
| 1576 | ]
|
|---|
| 1577 | :blk into [
|
|---|
| 1578 | (cont?: none)
|
|---|
| 1579 | thru 'edit set pair pair! pos-head: text: skip
|
|---|
| 1580 | any [
|
|---|
| 1581 | thru 'edit set save-pair pair!
|
|---|
| 1582 | (cont?: if offset/x < save-pair/x ['break])
|
|---|
| 1583 | cont?
|
|---|
| 1584 | text: skip (pair: save-pair)
|
|---|
| 1585 | ]
|
|---|
| 1586 | opt [to 'edit | (at-tail?: true)]
|
|---|
| 1587 | ]
|
|---|
| 1588 | ]
|
|---|
| 1589 | either string? text/1 [
|
|---|
| 1590 | offset: min length? text/1 to integer! offset/x - pair/x / f/x
|
|---|
| 1591 | cursor/xy: as-pair
|
|---|
| 1592 | offset * f/x + pair/x
|
|---|
| 1593 | y + 7
|
|---|
| 1594 | cursor/sub-string: skip text/1 offset
|
|---|
| 1595 | cursor/pos-len: offset + 1
|
|---|
| 1596 | ][
|
|---|
| 1597 | ;** special case, for tags (like tabulations)
|
|---|
| 1598 | len: length? get text/1
|
|---|
| 1599 | len: either offset/x < (f/x * len / 2 + pair/x) [0][len]
|
|---|
| 1600 | cursor/xy: as-pair f/x * len + pair/x y + 7
|
|---|
| 1601 | cursor/sub-string: text/1
|
|---|
| 1602 | cursor/pos-len: 1 + len
|
|---|
| 1603 | ]
|
|---|
| 1604 | cursor/head?: pos-head
|
|---|
| 1605 | cursor/data: blk
|
|---|
| 1606 | cursor/pos-blk: text
|
|---|
| 1607 | cursor/idx: idx
|
|---|
| 1608 | cursor/global-idx: idx - 1 + index? f/data
|
|---|
| 1609 |
|
|---|
| 1610 | case [
|
|---|
| 1611 | cursor/xy/x < 0 [scroll-x f -20 * f/x + cursor/xy/x]
|
|---|
| 1612 | cursor/xy/x > f/size/x [scroll-x f f/x * 20 + f/xy/x + cursor/xy/x - f/size/x]
|
|---|
| 1613 | ]
|
|---|
| 1614 | ]
|
|---|
| 1615 | ]
|
|---|
| 1616 | append init [
|
|---|
| 1617 | data: append/only make block! 1000 reduce [0 ""]
|
|---|
| 1618 | v-scroller: make v-scroller []
|
|---|
| 1619 | h-scroller: make h-scroller []
|
|---|
| 1620 | cursor: make cursor []
|
|---|
| 1621 | pane: reduce [cursor v-scroller h-scroller]
|
|---|
| 1622 | edge: make edge []
|
|---|
| 1623 | data: build-data [""] self
|
|---|
| 1624 | feel/resize self first reduce [size size: 0]
|
|---|
| 1625 | feel/inc-font-size f 0
|
|---|
| 1626 | ;** remove the event handler if found
|
|---|
| 1627 | foreach func system/view/screen-face/feel/event-funcs [
|
|---|
| 1628 | if {area-tc handler} = pick third :func 1 [
|
|---|
| 1629 | remove-event-func :func
|
|---|
| 1630 | ]
|
|---|
| 1631 | ]
|
|---|
| 1632 | insert-event-func :event-func
|
|---|
| 1633 | ]
|
|---|
| 1634 | export: context [
|
|---|
| 1635 | font+: func [f][f/feel/inc-font-size f +1]
|
|---|
| 1636 | font-: func [f][f/feel/inc-font-size f -1]
|
|---|
| 1637 | bold: func [f][f/feel/bold f]
|
|---|
| 1638 | ]
|
|---|
| 1639 | ]
|
|---|
| 1640 |
|
|---|
| 1641 | ]
|
|---|
| 1642 | ] ;** end of global context
|
|---|
| 1643 |
|
|---|
| 1644 |
|
|---|
| 1645 | ; API layouts
|
|---|
| 1646 |
|
|---|
| 1647 | pref_win: layout [
|
|---|
| 1648 | across
|
|---|
| 1649 | ;text "Rebol VM path:"
|
|---|
| 1650 | ;return
|
|---|
| 1651 | ;fi: field 300 pref/consol_path btn "..." [ if none? (fi/text: request-file/title/filter "Choose REBOL VM" "Select" "*.exe" ) [ fi/text: pref/consol_path ] show fi]
|
|---|
| 1652 | return
|
|---|
| 1653 | text "API Colors"
|
|---|
| 1654 | return
|
|---|
| 1655 | text "Background color:" b1: box 20x20 pref/bg_color btn "..." [ if none? b1/color: request-color [b1/color: white ] show b1 ]
|
|---|
| 1656 | return
|
|---|
| 1657 | text "Default text color:" b2: box 20x20 pref/txt_color btn "..." [ if none? b2/color: request-color [ b2/color: black ] show b2]
|
|---|
| 1658 | return tab
|
|---|
| 1659 | btn "Ok" [ sav-pref t/color: pref/bg_color unview/only pref_win render-text/stay t 1 show t]
|
|---|
| 1660 | btn "Cancel" [ unview/only pref_win ]
|
|---|
| 1661 | ]
|
|---|
| 1662 |
|
|---|
| 1663 |
|
|---|
| 1664 | ;** TEST
|
|---|
| 1665 | do test: does [
|
|---|
| 1666 | unview/all
|
|---|
| 1667 | view/new/options layout [
|
|---|
| 1668 | across space 0x0 origin 0x0
|
|---|
| 1669 | mn: menu with [
|
|---|
| 1670 | size: 750x20 data: compose/deep [
|
|---|
| 1671 | "File" [
|
|---|
| 1672 | "New" # "Ctrl+N" [if request "Start a new file?" [t/data: build-data "" t render-text/stay t 1 ]]
|
|---|
| 1673 | "Open" # "Ctrl+O" [t/open-file none]
|
|---|
| 1674 | "Close" # "Ctrl+W"
|
|---|
| 1675 | bar
|
|---|
| 1676 | "Save" # "Ctrl+S" [ if request "Save file ? " [ t/save-file]]
|
|---|
| 1677 | bar
|
|---|
| 1678 | "Exit" [quit]
|
|---|
| 1679 | ]
|
|---|
| 1680 | "View" [
|
|---|
| 1681 | "Text Size" sub [
|
|---|
| 1682 | "Text +" [t/export/font+ t]
|
|---|
| 1683 | "Text -" [t/export/font- t]
|
|---|
| 1684 | ]
|
|---|
| 1685 | "BOLD/NORMAL" [t/export/bold t]
|
|---|
| 1686 | "Functions" [l/draw-list]
|
|---|
| 1687 | ]
|
|---|
| 1688 | "Script" [
|
|---|
| 1689 | "Run" # "F1" [ if request "Run this Script ?" [ t/run_scr ] ]
|
|---|
| 1690 | ]
|
|---|
| 1691 | "Tools" [
|
|---|
| 1692 | "Preferencies" [ view/new pref_win ]
|
|---|
| 1693 | ]
|
|---|
| 1694 | "Help" [
|
|---|
| 1695 | "About..." [alert "WEB: http://my-trac.assembla.com/shadwolforge"]
|
|---|
| 1696 | ]
|
|---|
| 1697 | ]
|
|---|
| 1698 | ]
|
|---|
| 1699 | below across
|
|---|
| 1700 | l: func-view 100x500
|
|---|
| 1701 |
|
|---|
| 1702 | t: area-tc 650x500
|
|---|
| 1703 | ][resize]
|
|---|
| 1704 | if exists? %area-tc-03-menu3.r [t/open-file %area-tc-03-menu3.r]
|
|---|
| 1705 | do-events
|
|---|
| 1706 | ]
|
|---|
| 1707 | halt
|
|---|
| 1708 |
|
|---|
