REBOL [
	TITLE: "colorisation syntaxique"
	auteur: "Shadwolf"
	date: 18/03/2009 
	credits: { Carl sassenrath, Steeve, Maxim, Coccinelle 
	(all inspiring and source code thank alot from the bottom of my heart)}
	purpose: {offert the rendering in colorized text in a 'box using draw/agg }
]
comment {
 Todo:
  commençons simplement par charger un fichier source rebol et 
  a l'afficher en couleur dans une 'box en read only en utilisant 
  draw/agg (font fixe seul la couleur varie)
  Par la suite quand on aura un beau résultat a l'ecran et une bonne 
  structure mémoire/ rendu nous pourrons nous occupé de l'aspect saisie de texte dynamique.  
  
}

script-color-ctx: context  [
; contient les fonctions pour convertir le texte ascii brute en instructions AGG
 colors: [
         char!          0.120.40
         date!          0.120.150
         decimal!       0.120.150
         email!         0.120.40
         file!          0.120.40
         integer!       0.120.150
         issue!         0.120.40
         money!         0.120.150
         pair!          0.120.150
         string!        0.120.40
         tag!           0.120.40
         time!          0.120.150
         tuple!         0.120.150
         url!           0.120.40
         refinement!    160.120.40
         cmt            10.10.160
    ]

    out: none

    emit: func [data] [repend out data]


    emit-color: func [value start stop /local color][
        either none? :value [color: select colors 'cmt][
            if path? :value [value: first :value]
            color: either word? :value [
                any [
                    all [value? :value any-function? get :value 140.0.0]
                    all [value? :value datatype? get :value 120.60.100]
                ]
            ][
                any [select colors type?/word :value]
            ]
        ]
        either color [ ; (Done this way so script can color itself.)
            emit [ color 
                copy/part start stop ]
        ][
            emit copy/part start stop
        ]
    ]
    char-array: make block! [60]
	get-string: func [char][
		any [
			select/case char-array char 
			first back change insert tail char-array char to-string char
		]
	]
; fonction globalisée pour être appellée depuis l'exterrieur
    set 'color-code func [ 
        "Return color source code as HTML."
        text [string!] "Source code text"
        /local str new value
    ][
        ;out: make string! 3 * length? text
		out: copy []
        set [value text] load/next  text
        emit copy/part head text text
        spc: charset [#"^(1)" - #" "] ; treat like space

        parse/all text blk-rule: [
            some [
                str:
                some spc new: (emit copy/part str new) |
                newline (emit newline)|
                #";" [thru newline | to end] new: 
                    (emit-color none str new) |
                [#"[" | #"("] (emit get-string first str) blk-rule |
                [#"]" | #")"] (emit get-string first str) break |
                skip (
                    set [value new] load/next str
                    emit-color :value str new
                ) :new
            ]
        ]

      ; probe out ; dbg  
       return out
    ]
]





area-tc-ctx: context  [

	; steeve's suggestion to save memory	
	char-array: make block! [60]
	get-string: func [char][
		any [
			select/case char-array char 
			first back change insert tail char-array char to-string char
		]
	]

	set 'open-file func [ /local file  ] [
		recycle
		file: request-file
		if file [ 
			t/data: create-ascii-tab color-code read first file 
			render-text t 
		] 
	]
	
	create-ascii-tab: func [ tdm-data 
		/local cur-color def-color
		item  
		letter
		ascii-tab
		ascii-line
		curr-off
		w z
		]
	[
		cur-color: 0.0.0
		def-color: 0.0.0
		curr-off: 5X5
		ascii-tab: copy []
		ascii-line: copy []
		;cette fonction converti les données TDM (lue depuis le fichier traitée par color-color
		; en donnée draw
		foreach item tdm-data [ 
			if (type? item) = tuple! [ cur-color: :item ]
			if (type? item) = any [ string! char! ] [

				foreach letter  item [
					letter: get-string letter ; steeve's suggestion
					switch/default letter [
						"^/" [
							;insert tail ascii-line compose/deep [ (curr-off)  (letter) (cur-color)]
							;insert tail ascii-tab compose [ (ascii-line)]
							insert insert insert tail ascii-line curr-off  letter cur-color 
							insert/only tail ascii-tab  ascii-line
							ascii-line: copy [] 
							curr-off/x: 5 
							;curr-off/y: curr-off/y + 18
								 
						]
						"^-" [ curr-off/x: curr-off/x + 20 ] ;tab
						
						
						;#" " [ cur-color: 0.0.0]
					][
						insert insert insert tail ascii-line curr-off letter cur-color
; on incremente curr-off pour le prochain ascii
;on utilise la métode de calcul de taille simplifiée de Coccinelle size-text marche très bien ^^ 
    				curr-off/x: curr-off/x + 8;z/x 		
					]
				]
				cur-color: 0.0.0 ; remise a default de la couleur	
			]
		
		]; fin premier foreach
		return ascii-tab  
	]

	render-text: func [ f
	/local pos char color font-obj draw-txt
	prev-col draw-sblk i curr-pos
	][	
start: now/precise
		i: 1 prev-col: none
		
		font-obj: make face/font [ name: font-fixed size: 14]
		;draw-txt: compose [ translate (0x-18 * f/area-start) push pen none  ]
		draw-txt: compose [ push pen none  ]
		insert insert tail draw-txt 'font font-obj
		insert insert tail draw-txt 'line-width 0.5
		
		foreach line copy/part at f/data f/area-start at f/data f/area-end [
			insert insert tail draw-txt 'translate  0x18 
			insert tail draw-txt 'push
			draw-sblk: copy []
			a: make string! 1
			cur-pos: first line 
			prev-col: third line
			insert insert tail draw-sblk 'fill-pen  third line
  			foreach [ pos char  color ] line [
					if color <> prev-col [
						insert insert insert insert tail draw-sblk 'text 'vectorial cur-pos a
						insert insert tail draw-sblk 'fill-pen color 
						a: make string! 1
						cur-pos: pos 
					]
					append a char 
					;insert insert insert insert tail draw-sblk 'text 'vectorial pos char 
					prev-col: :color
				
  			]
  			insert insert insert insert tail draw-sblk 'text 'vectorial cur-pos a
  			;probe draw-sblk halt ; dbg
  			insert/only tail draw-txt draw-sblk
  			if i > f/area-end [break]
  			i: i + 1
	  	]	
		f/effect: none 
		f/effect: compose/only [ draw (draw-txt) ]
		show f
probe difference now/precise start
	]
	top-face: func [
	face [object!] "starting face for test"
	point [pair!] "point to verify"
	;/scrollwheel direction "top-most which has feel/scrollwheel"
	;/type tp [word!] "top-most gl-class of this type"
	/local lcl-face i rval
][
	rval: either within? point win-offset? face face/size [
		any [
			either none? face/pane [
				face
			][
				i: 1
				while [
					all [
						block? face/pane
						(i <= length? face/pane)
						(none? lcl-face: top-face face/pane/:i point )
					]
				][
					i: i + 1
				]
				any [lcl-face face]
			]
			face
		]
	][
		none
	]
]


off-mem: 0x0

insert-event-func func [face event][
	switch event/type [
		scroll-line [
			face: event/face
			
			; find the top-most scroller!
			face: top-face event/face off-mem
			
			if face [
				if in face/feel 'scrollwheel [
					face/feel/scrollwheel face event off-mem - win-offset? face
				]
			]
		]
		move [
			off-mem: event/offset
		]
	]
	event
]
	
	stylize/master [
		area-tc: box with [
			color: white 
			text-cursor-position: none ;postion courante du curseur
		    start-higlight: none ; début sélection
			end-highlight: none ; fin sélection
	    	highlight-cnt: none ; contenu de la séléction
			data: none 
			area-start: 1
			area-end: 0		    
			feel: make feel [
				detect: func [f event] [
					if event/type == 'down [
						f/colors: ['black 'white]
						focus f 
					]	
					
					event	
				] 
				scrollwheel: func [f event offset] [
					dir: either event/offset/y > 0 ['down]['up]
					switch dir [
						down [ ; A FAIRE
						;probe "DOWN key used"
							if f/area-end <> (4 + length? f/data) [
								f/area-start: f/area-start + 3
								f/area-end: f/area-end + 3  
								render-text f
							]
						]
						up [ ; A FAIRE 
							if f/area-start <> 1 [
								f/area-start: f/area-start - 3
								f/area-end: f/area-end - 3  
								render-text f
							]
						]
					]
				]
				engage: func [f a e /local key] [
					switch a [
						key [
							key: e/key
							switch/default key [
								#"^M" [ ; touche entrer
							 	; pas implémenter pour l'instant
								]
								#"^[" [ ;touche escape ne fait rien
								]
								#"^~" [ ; touche suppr
								;A FAIRE
								]	
								right [ ; A FAIRE 
								]
								left [ ; A FAIRE 
								]
								down [ ; A FAIRE
								;probe "DOWN key used"
									if f/area-end <> (4 + length? f/data) [
										f/area-start: f/area-start + 1
										f/area-end: f/area-end + 1  
										render-text f
									]
								]
								up [ ; A FAIRE 
									if f/area-start <> 1 [
										f/area-start: f/area-start - 1
										f/area-end: f/area-end - 1  
										render-text f
									]
								]
								
							][ ; insertion d'un char
								render-text f key
							]
						
						]
					] ;fin switch   
				]; fin engage
	
			]; fin engage 
			append init [
				area-end: (size/y / 18)
		
			]
		]; fin feel:
		
	]
]




view layout  [
	below
	btn "open" [ open-file ]
	t: area-tc 600x400
	btn "dbg" [ do %../Anamonitor.r ]
	btn "Quit" [quit]
]