#!/usr/local/bin/clisp -ansi -q -E utf-8
;;;; -*- mode: lisp; coding:utf-8 -*-
;;;;FILE:              eurnews
;;;;LANGUAGE:          Common-Lisp
;;;;SYSTEM:            UNIX
;;;;    Note: we compile on load only to check syntax errors faster.
;;;;    euronews --help
;;;;    <PJB> Pascal J. Bourguignon
;;;;    2004-03-24 <PJB> Added user selectable language.
;;;;    2002-09-30 <PJB> Created.
;;;;    Copyright Pascal J. Bourguignon 2002 - 2004
;;;;    This script is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU  General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 2 of the License, or (at your option) any later version.
;;;;    This script is distributed in the hope that it will be useful,
;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;    General Public License for more details.
;;;;    You should have received a copy of the GNU General Public
;;;;    License along with this library; see the file COPYING.LIB.
;;;;    If not, write to the Free Software Foundation,
;;;;    59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(in-package "COMMON-LISP-USER")
(load (make-pathname :name "SCRIPT" :type "LISP" :version NIL :case :common :defaults *load-pathname*))
(use-package "SCRIPT")
(defparameter *program-version* "1.0.2")

(defvar do-clear    t "Whether clear screen actuall works.")
(defun clear () (when do-clear (ext:run-program "/usr/bin/clear")))

(defvar language    "ge" "The language selected for euronews.")
(defvar index       0)
(defvar last-index  0)
(defvar previous    nil)
(defvar urls        '())
(defvar length-urls 0)
(defvar played      nil)
(defvar played-last nil)
(defvar menu-items  '())

(defconstant +available-languages+ '(de fr en it es ru))

(defun language-to-euronews (lang)
     ((member lang '("ge" "de") :test 'string-equal) "ge")
     ((member lang '("es" "sp") :test 'string-equal) "sp")
     ((member lang +available-languages+ :test 'string-equal) lang)
     (t nil)));;language-to-euronews

(dolist (arg (if (boundp 'ext:*args*) ext:*args* nil))
  (setq language (language-to-euronews arg))
  (unless language
    (format t "~%usage:~%")
    (format t "   euronews  [de|fr|en|it|es|po|ru]~%")
    (ext:exit ex-usage)))

(defun stream-to-string-list (stream)
  (loop with line = (read-line stream nil nil)
        while line
        collect line into result
        do (setq line (read-line stream nil nil))
        finally (return result)))

(defun played-indicator      (index)  (if (aref played index) "*" " "))
(defun played-last-indicator (index)  (if (= index played-last) "#" " "))
(defun set-played (index  rest)
  (when rest (setq played-last index))
  (setf (aref played index) rest))

(defun get-urls ()
  (setq previous nil)
  (setq urls
        (loop for item in (sort
                           (loop for page in '( "accueil_info" "acceuil_eco" "euro" "lemag" "hitech" )
                                 for new-urls = (stream-to-string-list
                                                  (format nil "{ lynx -source 'http://www.euronews.net/create_html.php?page=~A&langue=~A'|tr '<' '\\012'|grep ramgen|sed -e 's/.*lien=\\(.*hostname\\).*/http:\\/\\/\\1/' ;}" page language)
                                                  :input     nil
                                                  :output    :stream))
                                 ;;do (format t "new-urls=~S~%" new-urls)
                                 append new-urls into all-urls
                                 finally (return all-urls))
              ;;do (format t "item=~S~%" item)
              when (and previous (string/= previous item))
              collect item into all-urls
              do (setq previous item)
              finally (return all-urls)))
  (setq length-urls (length urls)) ;;get-urls
  (setq played (make-array (list length-urls) :initial-element nil))
  (setq played-last -1)
  (setq last-index 1));;get-urls

(defun get-file-name (url)
  (let ((question nil)
        (slash nil))
  (loop for index from (1- (length url)) downto 0
        until slash
        when (char= (char url index) (character '\?)) do (setq question index)
        when (char= (char url index) (character '\/)) do (setq slash index)
        finally (return (subseq url (1+ slash) question))))

;; The main script:
;; ----------------

(loop while (and (/= 0 last-index) (<= last-index length-urls))
      ;; index is counted between 1 and (length urls)
      ;; index==0 means quit
      ;; urls list and played array are  0 indexed though.

      (setq menu-items
            (loop for index = 0 then (1+ index)
            for url in urls
            collect (format nil "~2D ~1A~1A ~34A"
                       (1+ index)
                       (played-indicator        index)
                       (played-last-indicator   index)
                       (get-file-name (elt urls index)))
            into menu-items
            finally (return menu-items)))
      (loop for line from 0 to 21
            for menu = line
            do (loop for menu = line then (+ 22 menu)
                     while (< menu (length menu-items))
                     do (format t "~40A" (elt menu-items menu))
                     finally (format t "~%")))

      (format t "~%Number to play (0 to quit) or language ~S: "
      (setq index (read))
       ((member index +available-languages+)
         (setq language (language-to-euronews index))
       ((numberp index)
        (if (and (<= 0 index) (<= index length-urls))
            (setq last-index index)
            (format t "Invalid option!")
            (setq last-index (- 0 last-index)))))
       ((eq 'n index)
        (setq last-index (1+ (mod last-index length-urls))))
       ((eq 'p index)
        (setq last-index (1+ (mod (- last-index 2) length-urls))))
       ((eq 'q index)
        (setq last-index 0))
       ((eq 'r index)
        ;; replay - no change
        (format t "Invalid option!")
        (setq last-index (- 0 last-index))))

      (when (< 0 last-index)
        (ext::shell (format nil "/local/apps/RealPlayer8/realplay '~A' &"
                             (elt urls (1- last-index))))
        (set-played (1- last-index) t)
        (setq index (1+ (mod last-index length-urls))))
      (setq last-index (abs last-index))

(ext:exit ex-ok)

;;;; euronews                         --                     --          ;;;;